ADDED .fossil-settings/crnl-glob Index: .fossil-settings/crnl-glob ================================================================== --- /dev/null +++ .fossil-settings/crnl-glob @@ -0,0 +1,1 @@ +docs/manual/megatest_manual.html Index: .fossil-settings/ignore-glob ================================================================== --- .fossil-settings/ignore-glob +++ .fossil-settings/ignore-glob @@ -1,5 +1,8 @@ +tests/fullrun/logs/* +tests/fullrun/lt +tests/fullrun/megatest.db altdb.scm utils/build/* *~ *.o bin/* ADDED .mtutil.scm Index: .mtutil.scm ================================================================== --- /dev/null +++ .mtutil.scm @@ -0,0 +1,84 @@ +;; Copyright 2006-2017, Matthew Welland. +;; +;; This file is part of Megatest. +;; +;; Megatest is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. +;; +;; Megatest is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with Megatest. If not, see . + +(use json) +(use ducttape-lib) + +(define (get-last-runname area-path target) + (let* ((run-data (with-input-from-pipe (conc "megatest -list-runs % -target " target " -fields runs:runname,event_time -dumpmode sexpr -start-dir " area-path) + read))) + (if (or (not run-data) + (null? run-data)) + #f + (let* ((name-time (let ((dat (map cdadr (alist-ref target run-data equal?)))) ;; (("runname" . "2017w07.0-0047") ("event_time" . "1487490424")) + ;; (print "dat=" dat) + (map (lambda (item) + (cons (alist-ref "runname" item equal?) + (string->number (alist-ref "event_time" item equal?)))) + dat))) + (sorted (sort name-time (lambda (a b)(> (cdr a)(cdr b))))) + (last-name (if (null? sorted) + #f + (caar sorted)))) + last-name)))) + +(define (str-first-char->number str) + (char->integer (string-ref str 0))) + +;; example of how to set up and write target mappers +;; +(add-target-mapper 'prefix-contour + (lambda (target run-name area area-path reason contour mode-patt) + (conc contour "/" target))) +(add-target-mapper 'prefix-area-contour + (lambda (target run-name area area-path reason contour mode-patt) + (conc area "/" contour "/" target))) + +(add-runname-mapper 'corporate-ww + (lambda (target run-name area area-path reason contour mode-patt) + (print "corporate-ww called with: target=" target " run-name=" run-name " area=" area " area-path=" area-path " reason=" reason " contour=" contour " mode-patt=" mode-patt) + (let* ((last-name (get-last-runname area-path target)) + (last-letter (let* ((ch (if (string? last-name) + (let ((len (string-length last-name))) + (substring last-name (- len 1) len)) + "a")) + (chnum (str-first-char->number ch)) + (a (str-first-char->number "a")) + (z (str-first-char->number "z"))) + (if (and (>= chnum a)(<= chnum z)) + chnum + #f))) + (next-letter (if last-letter + (list->string + (list + (integer->char + (+ last-letter 1)))) ;; surely there is an easier way? + "a"))) + ;; (print "last-name: " last-name " last-letter: " last-letter " next-letter: " next-letter) + (conc (seconds->wwdate (current-seconds)) next-letter)))) + +(add-runname-mapper 'auto + (lambda (target run-name area area-path reason contour mode-patt) + "auto-eh")) + +;; run only areas where first letter of area name is "a" +;; +(add-area-checker 'first-letter-a + (lambda (area target contour) + (string-match "^a.*$" area))) + + Index: COPYING ================================================================== --- COPYING +++ COPYING @@ -1,724 +1,675 @@ - GNU GENERAL PUBLIC LICENSE - Version 2, June 1991 + GNU GENERAL PUBLIC LICENSE - Copyright (C) 1989, 1991 Free Software Foundation, Inc. - 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA + Version 3, 29 June 2007 + + Copyright (C) 2007 Free Software Foundation, Inc. Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. - Preamble - - The licenses for most software are designed to take away your -freedom to share and change it. By contrast, the GNU General Public -License is intended to guarantee your freedom to share and change free -software--to make sure the software is free for all its users. This -General Public License applies to most of the Free Software -Foundation's software and to any other program whose authors commit to -using it. (Some other Free Software Foundation software is covered by -the GNU Library General Public License instead.) You can apply it to + Preamble + + The GNU General Public License is a free, copyleft license for +software and other kinds of works. + + The licenses for most software and other practical works are designed +to take away your freedom to share and change the works. By contrast, +the GNU General Public License is intended to guarantee your freedom to +share and change all versions of a program--to make sure it remains free +software for all its users. We, the Free Software Foundation, use the +GNU General Public License for most of our software; it applies also to +any other work released this way by its authors. You can apply it to your programs, too. When we speak of free software, we are referring to freedom, not price. Our General Public Licenses are designed to make sure that you have the freedom to distribute copies of free software (and charge for -this service if you wish), that you receive source code or can get it -if you want it, that you can change the software or use pieces of it -in new free programs; and that you know you can do these things. - - To protect your rights, we need to make restrictions that forbid -anyone to deny you these rights or to ask you to surrender the rights. -These restrictions translate to certain responsibilities for you if you -distribute copies of the software, or if you modify it. +them if you wish), that you receive source code or can get it if you +want it, that you can change the software or use pieces of it in new +free programs, and that you know you can do these things. + + To protect your rights, we need to prevent others from denying you +these rights or asking you to surrender the rights. Therefore, you have +certain responsibilities if you distribute copies of the software, or if +you modify it: responsibilities to respect the freedom of others. For example, if you distribute copies of such a program, whether -gratis or for a fee, you must give the recipients all the rights that -you have. You must make sure that they, too, receive or can get the -source code. And you must show them these terms so they know their -rights. - - We protect your rights with two steps: (1) copyright the software, and -(2) offer you this license which gives you legal permission to copy, -distribute and/or modify the software. - - Also, for each author's protection and ours, we want to make certain -that everyone understands that there is no warranty for this free -software. If the software is modified by someone else and passed on, we -want its recipients to know that what they have is not the original, so -that any problems introduced by others will not reflect on the original -authors' reputations. - - Finally, any free program is threatened constantly by software -patents. We wish to avoid the danger that redistributors of a free -program will individually obtain patent licenses, in effect making the -program proprietary. To prevent this, we have made it clear that any -patent must be licensed for everyone's free use or not licensed at all. +gratis or for a fee, you must pass on to the recipients the same +freedoms that you received. You must make sure that they, too, receive +or can get the source code. And you must show them these terms so they +know their rights. + + Developers that use the GNU GPL protect your rights with two steps: +(1) assert copyright on the software, and (2) offer you this License +giving you legal permission to copy, distribute and/or modify it. + + For the developers' and authors' protection, the GPL clearly explains +that there is no warranty for this free software. For both users' and +authors' sake, the GPL requires that modified versions be marked as +changed, so that their problems will not be attributed erroneously to +authors of previous versions. + + Some devices are designed to deny users access to install or run +modified versions of the software inside them, although the manufacturer +can do so. This is fundamentally incompatible with the aim of +protecting users' freedom to change the software. The systematic +pattern of such abuse occurs in the area of products for individuals to +use, which is precisely where it is most unacceptable. Therefore, we +have designed this version of the GPL to prohibit the practice for those +products. If such problems arise substantially in other domains, we +stand ready to extend this provision to those domains in future versions +of the GPL, as needed to protect the freedom of users. + + Finally, every program is threatened constantly by software patents. +States should not allow patents to restrict development and use of +software on general-purpose computers, but in those that do, we wish to +avoid the special danger that patents applied to a free program could +make it effectively proprietary. To prevent this, the GPL assures that +patents cannot be used to render the program non-free. The precise terms and conditions for copying, distribution and modification follow. - - GNU GENERAL PUBLIC LICENSE - TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION - - 0. This License applies to any program or other work which contains -a notice placed by the copyright holder saying it may be distributed -under the terms of this General Public License. The "Program", below, -refers to any such program or work, and a "work based on the Program" -means either the Program or any derivative work under copyright law: -that is to say, a work containing the Program or a portion of it, -either verbatim or with modifications and/or translated into another -language. (Hereinafter, translation is included without limitation in -the term "modification".) Each licensee is addressed as "you". - -Activities other than copying, distribution and modification are not -covered by this License; they are outside its scope. The act of -running the Program is not restricted, and the output from the Program -is covered only if its contents constitute a work based on the -Program (independent of having been made by running the Program). -Whether that is true depends on what the Program does. - - 1. You may copy and distribute verbatim copies of the Program's -source code as you receive it, in any medium, provided that you -conspicuously and appropriately publish on each copy an appropriate -copyright notice and disclaimer of warranty; keep intact all the -notices that refer to this License and to the absence of any warranty; -and give any other recipients of the Program a copy of this License -along with the Program. - -You may charge a fee for the physical act of transferring a copy, and -you may at your option offer warranty protection in exchange for a fee. - - 2. You may modify your copy or copies of the Program or any portion -of it, thus forming a work based on the Program, and copy and -distribute such modifications or work under the terms of Section 1 -above, provided that you also meet all of these conditions: - - a) You must cause the modified files to carry prominent notices - stating that you changed the files and the date of any change. - - b) You must cause any work that you distribute or publish, that in - whole or in part contains or is derived from the Program or any - part thereof, to be licensed as a whole at no charge to all third - parties under the terms of this License. - - c) If the modified program normally reads commands interactively - when run, you must cause it, when started running for such - interactive use in the most ordinary way, to print or display an - announcement including an appropriate copyright notice and a - notice that there is no warranty (or else, saying that you provide - a warranty) and that users may redistribute the program under - these conditions, and telling the user how to view a copy of this - License. (Exception: if the Program itself is interactive but - does not normally print such an announcement, your work based on - the Program is not required to print an announcement.) - -These requirements apply to the modified work as a whole. If -identifiable sections of that work are not derived from the Program, -and can be reasonably considered independent and separate works in -themselves, then this License, and its terms, do not apply to those -sections when you distribute them as separate works. But when you -distribute the same sections as part of a whole which is a work based -on the Program, the distribution of the whole must be on the terms of -this License, whose permissions for other licensees extend to the -entire whole, and thus to each and every part regardless of who wrote it. - -Thus, it is not the intent of this section to claim rights or contest -your rights to work written entirely by you; rather, the intent is to -exercise the right to control the distribution of derivative or -collective works based on the Program. - -In addition, mere aggregation of another work not based on the Program -with the Program (or with a work based on the Program) on a volume of -a storage or distribution medium does not bring the other work under -the scope of this License. - - 3. You may copy and distribute the Program (or a work based on it, -under Section 2) in object code or executable form under the terms of -Sections 1 and 2 above provided that you also do one of the following: - - a) Accompany it with the complete corresponding machine-readable - source code, which must be distributed under the terms of Sections - 1 and 2 above on a medium customarily used for software interchange; or, - - b) Accompany it with a written offer, valid for at least three - years, to give any third party, for a charge no more than your - cost of physically performing source distribution, a complete - machine-readable copy of the corresponding source code, to be - distributed under the terms of Sections 1 and 2 above on a medium - customarily used for software interchange; or, - - c) Accompany it with the information you received as to the offer - to distribute corresponding source code. (This alternative is - allowed only for noncommercial distribution and only if you - received the program in object code or executable form with such - an offer, in accord with Subsection b above.) - -The source code for a work means the preferred form of the work for -making modifications to it. For an executable work, complete source -code means all the source code for all modules it contains, plus any -associated interface definition files, plus the scripts used to -control compilation and installation of the executable. However, as a -special exception, the source code distributed need not include -anything that is normally distributed (in either source or binary -form) with the major components (compiler, kernel, and so on) of the -operating system on which the executable runs, unless that component -itself accompanies the executable. - -If distribution of executable or object code is made by offering -access to copy from a designated place, then offering equivalent -access to copy the source code from the same place counts as -distribution of the source code, even though third parties are not -compelled to copy the source along with the object code. - - 4. You may not copy, modify, sublicense, or distribute the Program -except as expressly provided under this License. Any attempt -otherwise to copy, modify, sublicense or distribute the Program is -void, and will automatically terminate your rights under this License. -However, parties who have received copies, or rights, from you under -this License will not have their licenses terminated so long as such -parties remain in full compliance. - - 5. You are not required to accept this License, since you have not -signed it. However, nothing else grants you permission to modify or -distribute the Program or its derivative works. These actions are -prohibited by law if you do not accept this License. Therefore, by -modifying or distributing the Program (or any work based on the -Program), you indicate your acceptance of this License to do so, and -all its terms and conditions for copying, distributing or modifying -the Program or works based on it. - - 6. Each time you redistribute the Program (or any work based on the -Program), the recipient automatically receives a license from the -original licensor to copy, distribute or modify the Program subject to -these terms and conditions. You may not impose any further -restrictions on the recipients' exercise of the rights granted herein. -You are not responsible for enforcing compliance by third parties to + + TERMS AND CONDITIONS + + 0. Definitions. + + "This License" refers to version 3 of the GNU General Public License. + + "Copyright" also means copyright-like laws that apply to other kinds of +works, such as semiconductor masks. + + "The Program" refers to any copyrightable work licensed under this +License. Each licensee is addressed as "you". "Licensees" and +"recipients" may be individuals or organizations. + + To "modify" a work means to copy from or adapt all or part of the work +in a fashion requiring copyright permission, other than the making of an +exact copy. The resulting work is called a "modified version" of the +earlier work or a work "based on" the earlier work. + + A "covered work" means either the unmodified Program or a work based +on the Program. + + To "propagate" a work means to do anything with it that, without +permission, would make you directly or secondarily liable for +infringement under applicable copyright law, except executing it on a +computer or modifying a private copy. Propagation includes copying, +distribution (with or without modification), making available to the +public, and in some countries other activities as well. + + To "convey" a work means any kind of propagation that enables other +parties to make or receive copies. Mere interaction with a user through +a computer network, with no transfer of a copy, is not conveying. + + An interactive user interface displays "Appropriate Legal Notices" +to the extent that it includes a convenient and prominently visible +feature that (1) displays an appropriate copyright notice, and (2) +tells the user that there is no warranty for the work (except to the +extent that warranties are provided), that licensees may convey the +work under this License, and how to view a copy of this License. If +the interface presents a list of user commands or options, such as a +menu, a prominent item in the list meets this criterion. + + 1. Source Code. + + The "source code" for a work means the preferred form of the work +for making modifications to it. "Object code" means any non-source +form of a work. + + A "Standard Interface" means an interface that either is an official +standard defined by a recognized standards body, or, in the case of +interfaces specified for a particular programming language, one that +is widely used among developers working in that language. + + The "System Libraries" of an executable work include anything, other +than the work as a whole, that (a) is included in the normal form of +packaging a Major Component, but which is not part of that Major +Component, and (b) serves only to enable use of the work with that +Major Component, or to implement a Standard Interface for which an +implementation is available to the public in source code form. A +"Major Component", in this context, means a major essential component +(kernel, window system, and so on) of the specific operating system +(if any) on which the executable work runs, or a compiler used to +produce the work, or an object code interpreter used to run it. + + The "Corresponding Source" for a work in object code form means all +the source code needed to generate, install, and (for an executable +work) run the object code and to modify the work, including scripts to +control those activities. However, it does not include the work's +System Libraries, or general-purpose tools or generally available free +programs which are used unmodified in performing those activities but +which are not part of the work. For example, Corresponding Source +includes interface definition files associated with source files for +the work, and the source code for shared libraries and dynamically +linked subprograms that the work is specifically designed to require, +such as by intimate data communication or control flow between those +subprograms and other parts of the work. + + The Corresponding Source need not include anything that users +can regenerate automatically from other parts of the Corresponding +Source. + + The Corresponding Source for a work in source code form is that +same work. + + 2. Basic Permissions. + + All rights granted under this License are granted for the term of +copyright on the Program, and are irrevocable provided the stated +conditions are met. This License explicitly affirms your unlimited +permission to run the unmodified Program. The output from running a +covered work is covered by this License only if the output, given its +content, constitutes a covered work. This License acknowledges your +rights of fair use or other equivalent, as provided by copyright law. + + You may make, run and propagate covered works that you do not +convey, without conditions so long as your license otherwise remains +in force. You may convey covered works to others for the sole purpose +of having them make modifications exclusively for you, or provide you +with facilities for running those works, provided that you comply with +the terms of this License in conveying all material for which you do +not control copyright. Those thus making or running the covered works +for you must do so exclusively on your behalf, under your direction +and control, on terms that prohibit them from making any copies of +your copyrighted material outside their relationship with you. + + Conveying under any other circumstances is permitted solely under +the conditions stated below. Sublicensing is not allowed; section 10 +makes it unnecessary. + + 3. Protecting Users' Legal Rights From Anti-Circumvention Law. + + No covered work shall be deemed part of an effective technological +measure under any applicable law fulfilling obligations under article +11 of the WIPO copyright treaty adopted on 20 December 1996, or +similar laws prohibiting or restricting circumvention of such +measures. + + When you convey a covered work, you waive any legal power to forbid +circumvention of technological measures to the extent such circumvention +is effected by exercising rights under this License with respect to +the covered work, and you disclaim any intention to limit operation or +modification of the work as a means of enforcing, against the work's +users, your or third parties' legal rights to forbid circumvention of +technological measures. + + 4. Conveying Verbatim Copies. + + You may convey verbatim copies of the Program's source code as you +receive it, in any medium, provided that you conspicuously and +appropriately publish on each copy an appropriate copyright notice; +keep intact all notices stating that this License and any +non-permissive terms added in accord with section 7 apply to the code; +keep intact all notices of the absence of any warranty; and give all +recipients a copy of this License along with the Program. + + You may charge any price or no price for each copy that you convey, +and you may offer support or warranty protection for a fee. + + 5. Conveying Modified Source Versions. + + You may convey a work based on the Program, or the modifications to +produce it from the Program, in the form of source code under the +terms of section 4, provided that you also meet all of these conditions: + + a) The work must carry prominent notices stating that you modified + it, and giving a relevant date. + + b) The work must carry prominent notices stating that it is + released under this License and any conditions added under section + 7. This requirement modifies the requirement in section 4 to + "keep intact all notices". + + c) You must license the entire work, as a whole, under this + License to anyone who comes into possession of a copy. This + License will therefore apply, along with any applicable section 7 + additional terms, to the whole of the work, and all its parts, + regardless of how they are packaged. This License gives no + permission to license the work in any other way, but it does not + invalidate such permission if you have separately received it. + + d) If the work has interactive user interfaces, each must display + Appropriate Legal Notices; however, if the Program has interactive + interfaces that do not display Appropriate Legal Notices, your + work need not make them do so. + + A compilation of a covered work with other separate and independent +works, which are not by their nature extensions of the covered work, +and which are not combined with it such as to form a larger program, +in or on a volume of a storage or distribution medium, is called an +"aggregate" if the compilation and its resulting copyright are not +used to limit the access or legal rights of the compilation's users +beyond what the individual works permit. Inclusion of a covered work +in an aggregate does not cause this License to apply to the other +parts of the aggregate. + + 6. Conveying Non-Source Forms. + + You may convey a covered work in object code form under the terms +of sections 4 and 5, provided that you also convey the +machine-readable Corresponding Source under the terms of this License, +in one of these ways: + + a) Convey the object code in, or embodied in, a physical product + (including a physical distribution medium), accompanied by the + Corresponding Source fixed on a durable physical medium + customarily used for software interchange. + + b) Convey the object code in, or embodied in, a physical product + (including a physical distribution medium), accompanied by a + written offer, valid for at least three years and valid for as + long as you offer spare parts or customer support for that product + model, to give anyone who possesses the object code either (1) a + copy of the Corresponding Source for all the software in the + product that is covered by this License, on a durable physical + medium customarily used for software interchange, for a price no + more than your reasonable cost of physically performing this + conveying of source, or (2) access to copy the + Corresponding Source from a network server at no charge. + + c) Convey individual copies of the object code with a copy of the + written offer to provide the Corresponding Source. This + alternative is allowed only occasionally and noncommercially, and + only if you received the object code with such an offer, in accord + with subsection 6b. + + d) Convey the object code by offering access from a designated + place (gratis or for a charge), and offer equivalent access to the + Corresponding Source in the same way through the same place at no + further charge. You need not require recipients to copy the + Corresponding Source along with the object code. If the place to + copy the object code is a network server, the Corresponding Source + may be on a different server (operated by you or a third party) + that supports equivalent copying facilities, provided you maintain + clear directions next to the object code saying where to find the + Corresponding Source. Regardless of what server hosts the + Corresponding Source, you remain obligated to ensure that it is + available for as long as needed to satisfy these requirements. + + e) Convey the object code using peer-to-peer transmission, provided + you inform other peers where the object code and Corresponding + Source of the work are being offered to the general public at no + charge under subsection 6d. + + A separable portion of the object code, whose source code is excluded +from the Corresponding Source as a System Library, need not be +included in conveying the object code work. + + A "User Product" is either (1) a "consumer product", which means any +tangible personal property which is normally used for personal, family, +or household purposes, or (2) anything designed or sold for incorporation +into a dwelling. In determining whether a product is a consumer product, +doubtful cases shall be resolved in favor of coverage. For a particular +product received by a particular user, "normally used" refers to a +typical or common use of that class of product, regardless of the status +of the particular user or of the way in which the particular user +actually uses, or expects or is expected to use, the product. A product +is a consumer product regardless of whether the product has substantial +commercial, industrial or non-consumer uses, unless such uses represent +the only significant mode of use of the product. + + "Installation Information" for a User Product means any methods, +procedures, authorization keys, or other information required to install +and execute modified versions of a covered work in that User Product from +a modified version of its Corresponding Source. The information must +suffice to ensure that the continued functioning of the modified object +code is in no case prevented or interfered with solely because +modification has been made. + + If you convey an object code work under this section in, or with, or +specifically for use in, a User Product, and the conveying occurs as +part of a transaction in which the right of possession and use of the +User Product is transferred to the recipient in perpetuity or for a +fixed term (regardless of how the transaction is characterized), the +Corresponding Source conveyed under this section must be accompanied +by the Installation Information. But this requirement does not apply +if neither you nor any third party retains the ability to install +modified object code on the User Product (for example, the work has +been installed in ROM). + + The requirement to provide Installation Information does not include a +requirement to continue to provide support service, warranty, or updates +for a work that has been modified or installed by the recipient, or for +the User Product in which it has been modified or installed. Access to a +network may be denied when the modification itself materially and +adversely affects the operation of the network or violates the rules and +protocols for communication across the network. + + Corresponding Source conveyed, and Installation Information provided, +in accord with this section must be in a format that is publicly +documented (and with an implementation available to the public in +source code form), and must require no special password or key for +unpacking, reading or copying. + + 7. Additional Terms. + + "Additional permissions" are terms that supplement the terms of this +License by making exceptions from one or more of its conditions. +Additional permissions that are applicable to the entire Program shall +be treated as though they were included in this License, to the extent +that they are valid under applicable law. If additional permissions +apply only to part of the Program, that part may be used separately +under those permissions, but the entire Program remains governed by +this License without regard to the additional permissions. + + When you convey a copy of a covered work, you may at your option +remove any additional permissions from that copy, or from any part of +it. (Additional permissions may be written to require their own +removal in certain cases when you modify the work.) You may place +additional permissions on material, added by you to a covered work, +for which you have or can give appropriate copyright permission. + + Notwithstanding any other provision of this License, for material you +add to a covered work, you may (if authorized by the copyright holders of +that material) supplement the terms of this License with terms: + + a) Disclaiming warranty or limiting liability differently from the + terms of sections 15 and 16 of this License; or + + b) Requiring preservation of specified reasonable legal notices or + author attributions in that material or in the Appropriate Legal + Notices displayed by works containing it; or + + c) Prohibiting misrepresentation of the origin of that material, or + requiring that modified versions of such material be marked in + reasonable ways as different from the original version; or + + d) Limiting the use for publicity purposes of names of licensors or + authors of the material; or + + e) Declining to grant rights under trademark law for use of some + trade names, trademarks, or service marks; or + + f) Requiring indemnification of licensors and authors of that + material by anyone who conveys the material (or modified versions of + it) with contractual assumptions of liability to the recipient, for + any liability that these contractual assumptions directly impose on + those licensors and authors. + + All other non-permissive additional terms are considered "further +restrictions" within the meaning of section 10. If the Program as you +received it, or any part of it, contains a notice stating that it is +governed by this License along with a term that is a further +restriction, you may remove that term. If a license document contains +a further restriction but permits relicensing or conveying under this +License, you may add to a covered work material governed by the terms +of that license document, provided that the further restriction does +not survive such relicensing or conveying. + + If you add terms to a covered work in accord with this section, you +must place, in the relevant source files, a statement of the +additional terms that apply to those files, or a notice indicating +where to find the applicable terms. + + Additional terms, permissive or non-permissive, may be stated in the +form of a separately written license, or stated as exceptions; +the above requirements apply either way. + + 8. Termination. + + You may not propagate or modify a covered work except as expressly +provided under this License. Any attempt otherwise to propagate or +modify it is void, and will automatically terminate your rights under +this License (including any patent licenses granted under the third +paragraph of section 11). + + However, if you cease all violation of this License, then your +license from a particular copyright holder is reinstated (a) +provisionally, unless and until the copyright holder explicitly and +finally terminates your license, and (b) permanently, if the copyright +holder fails to notify you of the violation by some reasonable means +prior to 60 days after the cessation. + + Moreover, your license from a particular copyright holder is +reinstated permanently if the copyright holder notifies you of the +violation by some reasonable means, this is the first time you have +received notice of violation of this License (for any work) from that +copyright holder, and you cure the violation prior to 30 days after +your receipt of the notice. + + Termination of your rights under this section does not terminate the +licenses of parties who have received copies or rights from you under +this License. If your rights have been terminated and not permanently +reinstated, you do not qualify to receive new licenses for the same +material under section 10. + + 9. Acceptance Not Required for Having Copies. + + You are not required to accept this License in order to receive or +run a copy of the Program. Ancillary propagation of a covered work +occurring solely as a consequence of using peer-to-peer transmission +to receive a copy likewise does not require acceptance. However, +nothing other than this License grants you permission to propagate or +modify any covered work. These actions infringe copyright if you do +not accept this License. Therefore, by modifying or propagating a +covered work, you indicate your acceptance of this License to do so. + + 10. Automatic Licensing of Downstream Recipients. + + Each time you convey a covered work, the recipient automatically +receives a license from the original licensors, to run, modify and +propagate that work, subject to this License. You are not responsible +for enforcing compliance by third parties with this License. + + An "entity transaction" is a transaction transferring control of an +organization, or substantially all assets of one, or subdividing an +organization, or merging organizations. If propagation of a covered +work results from an entity transaction, each party to that +transaction who receives a copy of the work also receives whatever +licenses to the work the party's predecessor in interest had or could +give under the previous paragraph, plus a right to possession of the +Corresponding Source of the work from the predecessor in interest, if +the predecessor has it or can get it with reasonable efforts. + + You may not impose any further restrictions on the exercise of the +rights granted or affirmed under this License. For example, you may +not impose a license fee, royalty, or other charge for exercise of +rights granted under this License, and you may not initiate litigation +(including a cross-claim or counterclaim in a lawsuit) alleging that +any patent claim is infringed by making, using, selling, offering for +sale, or importing the Program or any portion of it. + + 11. Patents. + + A "contributor" is a copyright holder who authorizes use under this +License of the Program or a work on which the Program is based. The +work thus licensed is called the contributor's "contributor version". + + A contributor's "essential patent claims" are all patent claims +owned or controlled by the contributor, whether already acquired or +hereafter acquired, that would be infringed by some manner, permitted +by this License, of making, using, or selling its contributor version, +but do not include claims that would be infringed only as a +consequence of further modification of the contributor version. For +purposes of this definition, "control" includes the right to grant +patent sublicenses in a manner consistent with the requirements of this License. - 7. If, as a consequence of a court judgment or allegation of patent -infringement or for any other reason (not limited to patent issues), -conditions are imposed on you (whether by court order, agreement or + Each contributor grants you a non-exclusive, worldwide, royalty-free +patent license under the contributor's essential patent claims, to +make, use, sell, offer for sale, import and otherwise run, modify and +propagate the contents of its contributor version. + + In the following three paragraphs, a "patent license" is any express +agreement or commitment, however denominated, not to enforce a patent +(such as an express permission to practice a patent or covenant not to +sue for patent infringement). To "grant" such a patent license to a +party means to make such an agreement or commitment not to enforce a +patent against the party. + + If you convey a covered work, knowingly relying on a patent license, +and the Corresponding Source of the work is not available for anyone +to copy, free of charge and under the terms of this License, through a +publicly available network server or other readily accessible means, +then you must either (1) cause the Corresponding Source to be so +available, or (2) arrange to deprive yourself of the benefit of the +patent license for this particular work, or (3) arrange, in a manner +consistent with the requirements of this License, to extend the patent +license to downstream recipients. "Knowingly relying" means you have +actual knowledge that, but for the patent license, your conveying the +covered work in a country, or your recipient's use of the covered work +in a country, would infringe one or more identifiable patents in that +country that you have reason to believe are valid. + + If, pursuant to or in connection with a single transaction or +arrangement, you convey, or propagate by procuring conveyance of, a +covered work, and grant a patent license to some of the parties +receiving the covered work authorizing them to use, propagate, modify +or convey a specific copy of the covered work, then the patent license +you grant is automatically extended to all recipients of the covered +work and works based on it. + + A patent license is "discriminatory" if it does not include within +the scope of its coverage, prohibits the exercise of, or is +conditioned on the non-exercise of one or more of the rights that are +specifically granted under this License. You may not convey a covered +work if you are a party to an arrangement with a third party that is +in the business of distributing software, under which you make payment +to the third party based on the extent of your activity of conveying +the work, and under which the third party grants, to any of the +parties who would receive the covered work from you, a discriminatory +patent license (a) in connection with copies of the covered work +conveyed by you (or copies made from those copies), or (b) primarily +for and in connection with specific products or compilations that +contain the covered work, unless you entered into that arrangement, +or that patent license was granted, prior to 28 March 2007. + + Nothing in this License shall be construed as excluding or limiting +any implied license or other defenses to infringement that may +otherwise be available to you under applicable patent law. + + 12. No Surrender of Others' Freedom. + + If conditions are imposed on you (whether by court order, agreement or otherwise) that contradict the conditions of this License, they do not -excuse you from the conditions of this License. If you cannot -distribute so as to satisfy simultaneously your obligations under this -License and any other pertinent obligations, then as a consequence you -may not distribute the Program at all. For example, if a patent -license would not permit royalty-free redistribution of the Program by -all those who receive copies directly or indirectly through you, then -the only way you could satisfy both it and this License would be to -refrain entirely from distribution of the Program. - -If any portion of this section is held invalid or unenforceable under -any particular circumstance, the balance of the section is intended to -apply and the section as a whole is intended to apply in other -circumstances. - -It is not the purpose of this section to induce you to infringe any -patents or other property right claims or to contest validity of any -such claims; this section has the sole purpose of protecting the -integrity of the free software distribution system, which is -implemented by public license practices. Many people have made -generous contributions to the wide range of software distributed -through that system in reliance on consistent application of that -system; it is up to the author/donor to decide if he or she is willing -to distribute software through any other system and a licensee cannot -impose that choice. - -This section is intended to make thoroughly clear what is believed to -be a consequence of the rest of this License. - - 8. If the distribution and/or use of the Program is restricted in -certain countries either by patents or by copyrighted interfaces, the -original copyright holder who places the Program under this License -may add an explicit geographical distribution limitation excluding -those countries, so that distribution is permitted only in or among -countries not thus excluded. In such case, this License incorporates -the limitation as if written in the body of this License. - - 9. The Free Software Foundation may publish revised and/or new versions -of the General Public License from time to time. Such new versions will +excuse you from the conditions of this License. If you cannot convey a +covered work so as to satisfy simultaneously your obligations under this +License and any other pertinent obligations, then as a consequence you may +not convey it at all. For example, if you agree to terms that obligate you +to collect a royalty for further conveying from those to whom you convey +the Program, the only way you could satisfy both those terms and this +License would be to refrain entirely from conveying the Program. + + 13. Use with the GNU Affero General Public License. + + Notwithstanding any other provision of this License, you have +permission to link or combine any covered work with a work licensed +under version 3 of the GNU Affero General Public License into a single +combined work, and to convey the resulting work. The terms of this +License will continue to apply to the part which is the covered work, +but the special requirements of the GNU Affero General Public License, +section 13, concerning interaction through a network will apply to the +combination as such. + + 14. Revised Versions of this License. + + The Free Software Foundation may publish revised and/or new versions of +the GNU General Public License from time to time. Such new versions will be similar in spirit to the present version, but may differ in detail to address new problems or concerns. -Each version is given a distinguishing version number. If the Program -specifies a version number of this License which applies to it and "any -later version", you have the option of following the terms and conditions -either of that version or of any later version published by the Free -Software Foundation. If the Program does not specify a version number of -this License, you may choose any version ever published by the Free Software -Foundation. - - 10. If you wish to incorporate parts of the Program into other free -programs whose distribution conditions are different, write to the author -to ask for permission. For software which is copyrighted by the Free -Software Foundation, write to the Free Software Foundation; we sometimes -make exceptions for this. Our decision will be guided by the two goals -of preserving the free status of all derivatives of our free software and -of promoting the sharing and reuse of software generally. - - NO WARRANTY - - 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY -FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN -OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES -PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED -OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF -MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS -TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE -PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, -REPAIR OR CORRECTION. - - 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING -WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR -REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, -INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING -OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED -TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY -YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER -PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE -POSSIBILITY OF SUCH DAMAGES. - - END OF TERMS AND CONDITIONS - - How to Apply These Terms to Your New Programs + Each version is given a distinguishing version number. If the +Program specifies that a certain numbered version of the GNU General +Public License "or any later version" applies to it, you have the +option of following the terms and conditions either of that numbered +version or of any later version published by the Free Software +Foundation. If the Program does not specify a version number of the +GNU General Public License, you may choose any version ever published +by the Free Software Foundation. + + If the Program specifies that a proxy can decide which future +versions of the GNU General Public License can be used, that proxy's +public statement of acceptance of a version permanently authorizes you +to choose that version for the Program. + + Later license versions may give you additional or different +permissions. However, no additional obligations are imposed on any +author or copyright holder as a result of your choosing to follow a +later version. + + 15. Disclaimer of Warranty. + + THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY +APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT +HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY +OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, +THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM +IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF +ALL NECESSARY SERVICING, REPAIR OR CORRECTION. + + 16. Limitation of Liability. + + IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING +WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS +THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY +GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE +USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF +DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD +PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), +EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF +SUCH DAMAGES. + + 17. Interpretation of Sections 15 and 16. + + If the disclaimer of warranty and limitation of liability provided +above cannot be given local legal effect according to their terms, +reviewing courts shall apply local law that most closely approximates +an absolute waiver of all civil liability in connection with the +Program, unless a warranty or assumption of liability accompanies a +copy of the Program in return for a fee. + + END OF TERMS AND CONDITIONS + + How to Apply These Terms to Your New Programs If you develop a new program, and you want it to be of the greatest possible use to the public, the best way to achieve this is to make it free software which everyone can redistribute and change under these terms. To do so, attach the following notices to the program. It is safest to attach them to the start of each source file to most effectively -convey the exclusion of warranty; and each file should have at least +state the exclusion of warranty; and each file should have at least the "copyright" line and a pointer to where the full notice is found. Copyright (C) - This program is free software; you can redistribute it and/or modify + This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by - the Free Software Foundation; either version 2 of the License, or + the Free Software Foundation, either version 3 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License - along with this program; if not, write to the Free Software - Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA - + along with this program. If not, see . Also add information on how to contact you by electronic and paper mail. -If the program is interactive, make it output a short notice like this -when it starts in an interactive mode: + If the program does terminal interaction, make it output a short +notice like this when it starts in an interactive mode: - Gnomovision version 69, Copyright (C) year name of author - Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. + Copyright (C) + This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'. This is free software, and you are welcome to redistribute it under certain conditions; type `show c' for details. The hypothetical commands `show w' and `show c' should show the appropriate -parts of the General Public License. Of course, the commands you use may -be called something other than `show w' and `show c'; they could even be -mouse-clicks or menu items--whatever suits your program. - -You should also get your employer (if you work as a programmer) or your -school, if any, to sign a "copyright disclaimer" for the program, if -necessary. Here is a sample; alter the names: - - Yoyodyne, Inc., hereby disclaims all copyright interest in the program - `Gnomovision' (which makes passes at compilers) written by James Hacker. - - , 1 April 1989 - Ty Coon, President of Vice - -This General Public License does not permit incorporating your program into -proprietary programs. If your program is a subroutine library, you may -consider it more useful to permit linking proprietary applications with the -library. If this is what you want to do, use the GNU Library General -Public License instead of this License. - - -GNU Free Documentation License -****************************** - - Version 1.1, March 2000 - Copyright (C) 2000 Free Software Foundation, Inc. - 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA - - Everyone is permitted to copy and distribute verbatim copies - of this license document, but changing it is not allowed. - - 0. PREAMBLE - - The purpose of this License is to make a manual, textbook, or other - written document "free" in the sense of freedom: to assure everyone - the effective freedom to copy and redistribute it, with or without - modifying it, either commercially or noncommercially. Secondarily, - this License preserves for the author and publisher a way to get - credit for their work, while not being considered responsible for - modifications made by others. - - This License is a kind of "copyleft", which means that derivative - works of the document must themselves be free in the same sense. - It complements the GNU General Public License, which is a copyleft - license designed for free software. - - We have designed this License in order to use it for manuals for - free software, because free software needs free documentation: a - free program should come with manuals providing the same freedoms - that the software does. But this License is not limited to - software manuals; it can be used for any textual work, regardless - of subject matter or whether it is published as a printed book. - We recommend this License principally for works whose purpose is - instruction or reference. - - 1. APPLICABILITY AND DEFINITIONS - - This License applies to any manual or other work that contains a - notice placed by the copyright holder saying it can be distributed - under the terms of this License. The "Document", below, refers to - any such manual or work. Any member of the public is a licensee, - and is addressed as "you". - - A "Modified Version" of the Document means any work containing the - Document or a portion of it, either copied verbatim, or with - modifications and/or translated into another language. - - A "Secondary Section" is a named appendix or a front-matter - section of the Document that deals exclusively with the - relationship of the publishers or authors of the Document to the - Document's overall subject (or to related matters) and contains - nothing that could fall directly within that overall subject. - (For example, if the Document is in part a textbook of - mathematics, a Secondary Section may not explain any mathematics.) - The relationship could be a matter of historical connection with - the subject or with related matters, or of legal, commercial, - philosophical, ethical or political position regarding them. - - The "Invariant Sections" are certain Secondary Sections whose - titles are designated, as being those of Invariant Sections, in - the notice that says that the Document is released under this - License. - - The "Cover Texts" are certain short passages of text that are - listed, as Front-Cover Texts or Back-Cover Texts, in the notice - that says that the Document is released under this License. - - A "Transparent" copy of the Document means a machine-readable copy, - represented in a format whose specification is available to the - general public, whose contents can be viewed and edited directly - and straightforwardly with generic text editors or (for images - composed of pixels) generic paint programs or (for drawings) some - widely available drawing editor, and that is suitable for input to - text formatters or for automatic translation to a variety of - formats suitable for input to text formatters. A copy made in an - otherwise Transparent file format whose markup has been designed - to thwart or discourage subsequent modification by readers is not - Transparent. A copy that is not "Transparent" is called "Opaque". - - Examples of suitable formats for Transparent copies include plain - ASCII without markup, Texinfo input format, LaTeX input format, - SGML or XML using a publicly available DTD, and - standard-conforming simple HTML designed for human modification. - Opaque formats include PostScript, PDF, proprietary formats that - can be read and edited only by proprietary word processors, SGML - or XML for which the DTD and/or processing tools are not generally - available, and the machine-generated HTML produced by some word - processors for output purposes only. - - The "Title Page" means, for a printed book, the title page itself, - plus such following pages as are needed to hold, legibly, the - material this License requires to appear in the title page. For - works in formats which do not have any title page as such, "Title - Page" means the text near the most prominent appearance of the - work's title, preceding the beginning of the body of the text. - - 2. VERBATIM COPYING - - You may copy and distribute the Document in any medium, either - commercially or noncommercially, provided that this License, the - copyright notices, and the license notice saying this License - applies to the Document are reproduced in all copies, and that you - add no other conditions whatsoever to those of this License. You - may not use technical measures to obstruct or control the reading - or further copying of the copies you make or distribute. However, - you may accept compensation in exchange for copies. If you - distribute a large enough number of copies you must also follow - the conditions in section 3. - - You may also lend copies, under the same conditions stated above, - and you may publicly display copies. - - 3. COPYING IN QUANTITY - - If you publish printed copies of the Document numbering more than - 100, and the Document's license notice requires Cover Texts, you - must enclose the copies in covers that carry, clearly and legibly, - all these Cover Texts: Front-Cover Texts on the front cover, and - Back-Cover Texts on the back cover. Both covers must also clearly - and legibly identify you as the publisher of these copies. The - front cover must present the full title with all words of the - title equally prominent and visible. You may add other material - on the covers in addition. Copying with changes limited to the - covers, as long as they preserve the title of the Document and - satisfy these conditions, can be treated as verbatim copying in - other respects. - - If the required texts for either cover are too voluminous to fit - legibly, you should put the first ones listed (as many as fit - reasonably) on the actual cover, and continue the rest onto - adjacent pages. - - If you publish or distribute Opaque copies of the Document - numbering more than 100, you must either include a - machine-readable Transparent copy along with each Opaque copy, or - state in or with each Opaque copy a publicly-accessible - computer-network location containing a complete Transparent copy - of the Document, free of added material, which the general - network-using public has access to download anonymously at no - charge using public-standard network protocols. If you use the - latter option, you must take reasonably prudent steps, when you - begin distribution of Opaque copies in quantity, to ensure that - this Transparent copy will remain thus accessible at the stated - location until at least one year after the last time you - distribute an Opaque copy (directly or through your agents or - retailers) of that edition to the public. - - It is requested, but not required, that you contact the authors of - the Document well before redistributing any large number of - copies, to give them a chance to provide you with an updated - version of the Document. - - 4. MODIFICATIONS - - You may copy and distribute a Modified Version of the Document - under the conditions of sections 2 and 3 above, provided that you - release the Modified Version under precisely this License, with - the Modified Version filling the role of the Document, thus - licensing distribution and modification of the Modified Version to - whoever possesses a copy of it. In addition, you must do these - things in the Modified Version: - - A. Use in the Title Page (and on the covers, if any) a title - distinct from that of the Document, and from those of - previous versions (which should, if there were any, be listed - in the History section of the Document). You may use the - same title as a previous version if the original publisher of - that version gives permission. - - B. List on the Title Page, as authors, one or more persons or - entities responsible for authorship of the modifications in - the Modified Version, together with at least five of the - principal authors of the Document (all of its principal - authors, if it has less than five). - - C. State on the Title page the name of the publisher of the - Modified Version, as the publisher. - - D. Preserve all the copyright notices of the Document. - - E. Add an appropriate copyright notice for your modifications - adjacent to the other copyright notices. - - F. Include, immediately after the copyright notices, a license - notice giving the public permission to use the Modified - Version under the terms of this License, in the form shown in - the Addendum below. - - G. Preserve in that license notice the full lists of Invariant - Sections and required Cover Texts given in the Document's - license notice. - - H. Include an unaltered copy of this License. - - I. Preserve the section entitled "History", and its title, and - add to it an item stating at least the title, year, new - authors, and publisher of the Modified Version as given on - the Title Page. If there is no section entitled "History" in - the Document, create one stating the title, year, authors, - and publisher of the Document as given on its Title Page, - then add an item describing the Modified Version as stated in - the previous sentence. - - J. Preserve the network location, if any, given in the Document - for public access to a Transparent copy of the Document, and - likewise the network locations given in the Document for - previous versions it was based on. These may be placed in - the "History" section. You may omit a network location for a - work that was published at least four years before the - Document itself, or if the original publisher of the version - it refers to gives permission. - - K. In any section entitled "Acknowledgments" or "Dedications", - preserve the section's title, and preserve in the section all - the substance and tone of each of the contributor - acknowledgments and/or dedications given therein. - - L. Preserve all the Invariant Sections of the Document, - unaltered in their text and in their titles. Section numbers - or the equivalent are not considered part of the section - titles. - - M. Delete any section entitled "Endorsements". Such a section - may not be included in the Modified Version. - - N. Do not retitle any existing section as "Endorsements" or to - conflict in title with any Invariant Section. - - If the Modified Version includes new front-matter sections or - appendices that qualify as Secondary Sections and contain no - material copied from the Document, you may at your option - designate some or all of these sections as invariant. To do this, - add their titles to the list of Invariant Sections in the Modified - Version's license notice. These titles must be distinct from any - other section titles. - - You may add a section entitled "Endorsements", provided it contains - nothing but endorsements of your Modified Version by various - parties--for example, statements of peer review or that the text - has been approved by an organization as the authoritative - definition of a standard. - - You may add a passage of up to five words as a Front-Cover Text, - and a passage of up to 25 words as a Back-Cover Text, to the end - of the list of Cover Texts in the Modified Version. Only one - passage of Front-Cover Text and one of Back-Cover Text may be - added by (or through arrangements made by) any one entity. If the - Document already includes a cover text for the same cover, - previously added by you or by arrangement made by the same entity - you are acting on behalf of, you may not add another; but you may - replace the old one, on explicit permission from the previous - publisher that added the old one. - - The author(s) and publisher(s) of the Document do not by this - License give permission to use their names for publicity for or to - assert or imply endorsement of any Modified Version. - - 5. COMBINING DOCUMENTS - - You may combine the Document with other documents released under - this License, under the terms defined in section 4 above for - modified versions, provided that you include in the combination - all of the Invariant Sections of all of the original documents, - unmodified, and list them all as Invariant Sections of your - combined work in its license notice. - - The combined work need only contain one copy of this License, and - multiple identical Invariant Sections may be replaced with a single - copy. If there are multiple Invariant Sections with the same name - but different contents, make the title of each such section unique - by adding at the end of it, in parentheses, the name of the - original author or publisher of that section if known, or else a - unique number. Make the same adjustment to the section titles in - the list of Invariant Sections in the license notice of the - combined work. - - In the combination, you must combine any sections entitled - "History" in the various original documents, forming one section - entitled "History"; likewise combine any sections entitled - "Acknowledgments", and any sections entitled "Dedications". You - must delete all sections entitled "Endorsements." - - 6. COLLECTIONS OF DOCUMENTS - - You may make a collection consisting of the Document and other - documents released under this License, and replace the individual - copies of this License in the various documents with a single copy - that is included in the collection, provided that you follow the - rules of this License for verbatim copying of each of the - documents in all other respects. - - You may extract a single document from such a collection, and - distribute it individually under this License, provided you insert - a copy of this License into the extracted document, and follow - this License in all other respects regarding verbatim copying of - that document. - - 7. AGGREGATION WITH INDEPENDENT WORKS - - A compilation of the Document or its derivatives with other - separate and independent documents or works, in or on a volume of - a storage or distribution medium, does not as a whole count as a - Modified Version of the Document, provided no compilation - copyright is claimed for the compilation. Such a compilation is - called an "aggregate", and this License does not apply to the - other self-contained works thus compiled with the Document, on - account of their being thus compiled, if they are not themselves - derivative works of the Document. - - If the Cover Text requirement of section 3 is applicable to these - copies of the Document, then if the Document is less than one - quarter of the entire aggregate, the Document's Cover Texts may be - placed on covers that surround only the Document within the - aggregate. Otherwise they must appear on covers around the whole - aggregate. - - 8. TRANSLATION - - Translation is considered a kind of modification, so you may - distribute translations of the Document under the terms of section - 4. Replacing Invariant Sections with translations requires special - permission from their copyright holders, but you may include - translations of some or all Invariant Sections in addition to the - original versions of these Invariant Sections. You may include a - translation of this License provided that you also include the - original English version of this License. In case of a - disagreement between the translation and the original English - version of this License, the original English version will prevail. - - 9. TERMINATION - - You may not copy, modify, sublicense, or distribute the Document - except as expressly provided for under this License. Any other - attempt to copy, modify, sublicense or distribute the Document is - void, and will automatically terminate your rights under this - License. However, parties who have received copies, or rights, - from you under this License will not have their licenses - terminated so long as such parties remain in full compliance. - - 10. FUTURE REVISIONS OF THIS LICENSE - - The Free Software Foundation may publish new, revised versions of - the GNU Free Documentation License from time to time. Such new - versions will be similar in spirit to the present version, but may - differ in detail to address new problems or concerns. See - `http://www.gnu.org/copyleft/'. - - Each version of the License is given a distinguishing version - number. If the Document specifies that a particular numbered - version of this License "or any later version" applies to it, you - have the option of following the terms and conditions either of - that specified version or of any later version that has been - published (not as a draft) by the Free Software Foundation. If - the Document does not specify a version number of this License, - you may choose any version ever published (not as a draft) by the - Free Software Foundation. - -ADDENDUM: How to use this License for your documents ----------------------------------------------------- - - To use this License in a document you have written, include a copy of -the License in the document and put the following copyright and license -notices just after the title page: - - Copyright (C) YEAR YOUR NAME. - Permission is granted to copy, distribute and/or modify this document - under the terms of the GNU Free Documentation License, Version 1.1 - or any later version published by the Free Software Foundation; - with the Invariant Sections being LIST THEIR TITLES, with the - Front-Cover Texts being LIST, and with the Back-Cover Texts being LIST. - A copy of the license is included in the section entitled ``GNU - Free Documentation License''. - - If you have no Invariant Sections, write "with no Invariant Sections" -instead of saying which ones are invariant. If you have no Front-Cover -Texts, write "no Front-Cover Texts" instead of "Front-Cover Texts being -LIST"; likewise for Back-Cover Texts. - - If your document contains nontrivial examples of program code, we -recommend releasing these examples in parallel under your choice of -free software license, such as the GNU General Public License, to -permit their use in free software. - +parts of the General Public License. Of course, your program's commands +might be different; for a GUI interface, you would use an "about box". + + You should also get your employer (if you work as a programmer) or school, +if any, to sign a "copyright disclaimer" for the program, if necessary. +For more information on this, and how to apply and follow the GNU GPL, see +. + + The GNU General Public License does not permit incorporating your program +into proprietary programs. If your program is a subroutine library, you +may consider it more useful to permit linking proprietary applications with +the library. If this is what you want to do, use the GNU Lesser General +Public License instead of this License. But first, please read +. ADDED DONE Index: DONE ================================================================== --- /dev/null +++ DONE @@ -0,0 +1,36 @@ +# Copyright 2006-2017, Matthew Welland. +# +# This file is part of Megatest. +# +# Megatest is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# Megatest is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with Megatest. If not, see . + +NOTE: This file gets copied occasionally into the wiki as "Roadmap DONE". + Do not make changes in the wiki, they will be lost! + +DONE +==== + +WW14 +. Streamline compilation - DONE, all non-official egg modules are now bundled. + +WW15 +. syscheck; touch file in home, tmp, runs, links and start xterm [DONE] + +WW16 +. archiving improvements/extentions [DONE] +.. -get-data, -put-data [DONE] +.. use MT_ vars if defined and no switch present [DONE] +.. fix archive "first run" bug [DONE] +.. areas path1 path2 ... -> search path for archives [NOT NEEDED - use -start-dir] +.. -propagate -> move archive data forward when it is found in older bundles [NOT NEEDED - simply repost the data] Index: Makefile ================================================================== --- Makefile +++ Makefile @@ -1,84 +1,215 @@ +# Copyright 2006-2017, Matthew Welland. +# +# This file is part of Megatest. +# +# Megatest is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# Megatest is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with Megatest. If not, see . + # make install CSCOPTS='-accumulate-profile -profile-name $(PWD)/profile-ww$(shell date +%V.%u)' +# rm .o ; make install CSCOPTS='-profile' ; ... ; chicken-profile | less +SHELL=/bin/bash PREFIX=$(PWD) -CSCOPTS= +CSCOPTS= INSTALL=install -SRCFILES = common.scm items.scm launch.scm \ - ods.scm runconfig.scm server.scm configf.scm \ - db.scm keys.scm margs.scm megatest-version.scm \ - process.scm runs.scm tasks.scm tests.scm genexample.scm \ - http-transport.scm nmsg-transport.scm filedb.scm \ - client.scm synchash.scm daemon.scm mt.scm \ - ezsteps.scm lock-queue.scm sdb.scm \ - rmt.scm api.scm tdb.scm rpc-transport.scm \ - portlogger.scm archive.scm env.scm - -# Eggs to install (straightforward ones) -EGGS=matchable readline apropos base64 regex-literals format regex-case test coops trace csv \ -dot-locking posix-utils posix-extras directory-utils hostinfo tcp-server rpc csv-xml fmt \ -json md5 awful http-client spiffy uri-common intarweb spiffy-request-vars \ -spiffy-directory-listing ssax sxml-serializer sxml-modifications iup canvas-draw sqlite3 - -GUISRCF = dashboard-tests.scm dashboard-guimonitor.scm gutils.scm dcommon.scm tree.scm vg.scm +SRCFILES = common.scm items.scm launch.scm ods.scm runconfig.scm \ + server.scm configf.scm db.scm keys.scm margs.scm \ + process.scm runs.scm tasks.scm tests.scm genexample.scm \ + http-transport.scm filedb.scm tdb.scm client.scm mt.scm \ + ezsteps.scm lock-queue.scm sdb.scm rmt.scm api.scm \ + subrun.scm portlogger.scm archive.scm env.scm \ + diff-report.scm cgisetup/models/pgdb.scm + +# module source files +MSRCFILES = adjutant.scm mutils.scm mttop.scm +# ftail.scm rmtmod.scm commonmod.scm removed +# MSRCFILES = ducttape-lib.scm pkts.scm stml2.scm cookie.scm mutils.scm \ +# mtargs.scm commonmod.scm dbmod.scm adjutant.scm ulex.scm \ +# rmtmod.scm apimod.scm + +GUISRCF = dashboard-context-menu.scm dashboard-tests.scm \ + dashboard-guimonitor.scm gutils.scm dcommon.scm tree.scm \ + vg.scm OFILES = $(SRCFILES:%.scm=%.o) GOFILES = $(GUISRCF:%.scm=%.o) + +MOFILES = $(addprefix mofiles/,$(MSRCFILES:%.scm=%.o)) +# compiled import files +MOIMPFILES = $(MSRCFILES:%.scm=%.import.o) + +%.import.o : %.import.scm + csc $(CSCOPTS) -unit $*.import -c $*.import.scm -o $*.import.o + +# I'm not sure the cp is a good idea, changed a lot of things and it may not have been necessary... +# mofiles/%.o %.import.scm : %.scm megatest-fossil-hash.scm +# @[ -e mofiles ] || mkdir -p mofiles +# csc $(CSCOPTS) -I mofiles -I $* -J -c $< -o $*.o +# cp $*.o mofiles/$*.o +# @touch $*.import.scm # ensure it is touched after the .o is made + +mofiles/%.o : %.scm + mkdir -p mofiles + csc $(CSCOPTS) -J -c $< -o mofiles/$*.o ADTLSCR=mt_laststep mt_runstep mt_ezstep HELPERS=$(addprefix $(PREFIX)/bin/,$(ADTLSCR)) DEPLOYHELPERS=$(addprefix deploytarg/,$(ADTLSCR)) MTESTHASH=$(shell fossil info|grep checkout:| awk '{print $$2}') -CSIPATH=$(shell which csi) -CKPATH=$(shell dirname $(shell dirname $(CSIPATH))) +ifeq ($(MTESTHASH),) +$(error MTESTHASH is broken!) +endif + +# CSIPATH=$(shell which csi) +# CKPATH=$(shell dirname $(shell dirname $(CSIPATH))) # ARCHSTR=$(shell uname -m)_$(shell uname -r) # BASH_MACHTYPE=$(shell bash -c "echo \$$MACHTYPE") # ARCHSTR=$(BASH_MACHTYPE)_$(shell lsb_release -sr) -ARCHSTR=$(shell lsb_release -sr) +ARCHSTR=$(shell if [[ -e /usr/bin/sw_vers ]]; then /usr/bin/sw_vers -productVersion; else lsb_release -sr; fi) # ARCHSTR=$(shell bash -c "echo \$$MACHTYPE") -all : $(PREFIX)/bin/.$(ARCHSTR) mtest dboard - -mtest: $(OFILES) readline-fix.scm megatest.o - csc $(CSCOPTS) $(OFILES) megatest.o -o mtest - -dboard : $(OFILES) $(GOFILES) dashboard.scm - csc $(CSCOPTS) $(OFILES) dashboard.scm $(GOFILES) -o dboard - -ndboard : newdashboard.scm $(OFILES) $(GOFILES) - csc $(CSCOPTS) $(OFILES) $(GOFILES) newdashboard.scm -o ndboard - -multi-dboard : multi-dboard.scm $(OFILES) $(GOFILES) - csc $(CSCOPTS) $(OFILES) $(GOFILES) multi-dboard.scm -o multi-dboard - -# -# $(PREFIX)/bin/revtagfsl : utils/revtagfsl.scm -# csc utils/revtagfsl.scm -o $(PREFIX)/bin/revtagfsl +PNGFILES = $(shell cd docs/manual;ls *png) + +# all : $(PREFIX)/bin/.$(ARCHSTR) mtest dboard mtut ndboard +all : $(PREFIX)/bin/.$(ARCHSTR) mtest dboard mtut tcmt + +mtest: $(OFILES) readline-fix.scm megatest.o $(MOFILES) $(MOIMPFILES) megatest-version.scm + csc $(CSCOPTS) $(OFILES) $(MOFILES) $(MOIMPFILES) megatest.o -o mtest + +showmtesthash: + @echo $(MTESTHASH) + +dboard : $(OFILES) $(GOFILES) dashboard.scm $(MOFILES) $(MOIMPFILES) megatest-version.scm megatest-fossil-hash.scm + csc $(CSCOPTS) $(OFILES) dashboard.scm $(GOFILES) $(MOFILES) $(MOIMPFILES) -o dboard + +mtut: $(OFILES) $(MOFILES) megatest-fossil-hash.scm mtut.scm megatest-version.scm + csc $(CSCOPTS) $(OFILES) $(MOFILES) mtut.scm -o mtut + +include makefile.inc +include chicken.makefile + +TCMTOBJS = \ + api.o \ + archive.o \ + cgisetup/models/pgdb.o \ + client.o \ + common.o \ + configf.o \ + db.o \ + env.o \ + http-transport.o \ + items.o \ + keys.o \ + launch.o \ + lock-queue.o \ + margs.o \ + mt.o \ + ods.o \ + portlogger.o \ + process.o \ + rmt.o \ + runconfig.o \ + runs.o \ + server.o \ + tasks.o \ + tdb.o \ + tests.o \ + subrun.o \ + ezsteps.o + +# mofiles/rmtmod.o \ +# mofiles/commonmod.o \ + +tcmt : $(TCMTOBJS) tcmt.scm megatest-version.scm + csc $(CSCOPTS) $(TCMTOBJS) $(MOFILES) $(MOIMPFILES) tcmt.scm -o tcmt + +# install documentation to $(PREFIX)/docs +# DOES NOT REBUILD DOCS +# +$(PREFIX)/share/docs/megatest_manual.html : docs/manual/megatest_manual.html + mkdir -p $(PREFIX)/share/docs + $(INSTALL) docs/manual/megatest_manual.html $(PREFIX)/share/docs/megatest_manual.html + for png in $(PNGFILES);do $(INSTALL) docs/manual/$$png $(PREFIX)/share/docs/$$png;done + +# add a fake dependency so this doens't copy everytime +$(PREFIX)/share/js/jquery-3.1.0.slim.min.js : # .fslckout + mkdir -p $(PREFIX)/share/js + fossil wiki export java-script-lib > $(PREFIX)/share/js/jquery-3.1.0.slim.min.js + +$(PREFIX)/share/db/mt-pg.sql : mt-pg.sql + mkdir -p $(PREFIX)/share/db + $(INSTALL) mt-pg.sql $(PREFIX)/share/db/mt-pg.sql # Special dependencies for the includes -tests.o db.o launch.o runs.o dashboard-tests.o dashboard-guimonitor.o dashboard-main.o monitor.o dashboard.o \ -archive.o megatest.o : db_records.scm -tests.o runs.o dashboard.o dashboard-tests.o dashboard-main.o : run_records.scm +$(MOFILE) $(MOIMPFILES) : megatest-fossil-hash.scm + +# common.o : mofiles/commonmod.o megatest-fossil-hash.scm + +# commonmod.o dashboard.o megatest.o tcmt.o apimod.o : megatest-fossil-hash.scm + +tests.o db.o launch.o runs.o dashboard-tests.o \ +dashboard-context-menu.o dashboard-guimonitor.o dashboard-main.o \ +monitor.o dashboard.o archive.o megatest.o : db_records.scm megatest-fossil-hash.scm + +tests.o runs.o dashboard.o dashboard-tests.o dashboard-context-menu.o dashboard-main.o : run_records.scm + db.o ezsteps.o keys.o launch.o megatest.o monitor.o runs-for-ref.o runs.o tests.o : key_records.scm + tests.o tasks.o dashboard-tasks.o : task_records.scm + runs.o : test_records.scm -megatest.o : megatest-fossil-hash.scm -client.scm common.scm configf.scm dashboard-guimonitor.scm dashboard-tests.scm dashboard.scm db.scm dcommon.scm ezsteps.scm fs-transport.scm http-transport.scm index-tree.scm items.scm keys.scm launch.scm megatest.scm monitor.scm mt.scm newdashboard.scm runconfig.scm runs.scm server.scm tdb.scm tests.scm tree.scm : common_records.scm rpc-transport.scm + +megatest.o : megatest-fossil-hash.scm megatest-version.scm + +rmt.scm client.scm common.scm configf.scm dashboard-guimonitor.scm dashboard-tests.scm dashboard.scm db.scm dcommon.scm ezsteps.scm fs-transport.scm http-transport.scm index-tree.scm items.scm keys.scm launch.scm megatest.scm monitor.scm mt.scm newdashboard.scm runconfig.scm runs.scm server.scm tdb.scm tests.scm tree.scm : common_records.scm megatest-version.scm + common_records.scm : altdb.scm -vg.o dashboard.o : vg_records.scm + +# mofiles/stml2.o : mofiles/cookie.o +# configf.o : mofiles/commonmod.o + +vg.o dashboard.o : vg_records.scm megatest-version.scm + +dcommon.o : run_records.scm + +mofiles/stml2.o : mofiles/cookie.o + +# # special include based modules +# mofiles/pkts.o : pkts/pkts.scm +# mofiles/stml2.o : cookie.o +# # mofiles/mtargs.o : mtargs/mtargs.scm +# # mofiles/mtconfigf.o : mtconfigf/mtconfigf.scm +# mofiles/ulex.o : ulex/ulex.scm +# mofiles/mutils.o : mutils/mutils.scm +# mofiles/cookie.o : stml2/cookie.scm +# mofiles/stml2.o : stml2/stml2.scm # Temporary while transitioning to new routine # runs.o : run-tests-queue-classic.scm run-tests-queue-new.scm +# for the modularized stuff +mofiles/rmtmod.o : mofiles/commonmod.o + megatest-fossil-hash.scm : $(SRCFILES) megatest.scm *_records.scm echo "(define megatest-fossil-hash \"$(MTESTHASH)\")" > megatest-fossil-hash.new if ! diff -q megatest-fossil-hash.new megatest-fossil-hash.scm ; then echo copying .new to .scm;cp -f megatest-fossil-hash.new megatest-fossil-hash.scm;fi $(OFILES) $(GOFILES) : common_records.scm -%.o : %.scm - csc $(CSCOPTS) -c $< +%.o : %.scm $(MOFILES) + csc $(CSCOPTS) -c $< $(MOFILES) $(PREFIX)/bin/.$(ARCHSTR)/mtest : mtest utils/mk_wrapper @echo Installing to PREFIX=$(PREFIX) $(INSTALL) mtest $(PREFIX)/bin/.$(ARCHSTR)/mtest utils/mk_wrapper $(PREFIX) mtest $(PREFIX)/bin/megatest @@ -89,28 +220,54 @@ $(PREFIX)/bin/newdashboard : $(PREFIX)/bin/.$(ARCHSTR)/ndboard utils/mk_wrapper utils/mk_wrapper $(PREFIX) ndboard $(PREFIX)/bin/newdashboard chmod a+x $(PREFIX)/bin/newdashboard -$(PREFIX)/bin/.$(ARCHSTR)/mdboard : multi-dboard - $(INSTALL) multi-dboard $(PREFIX)/bin/.$(ARCHSTR)/mdboard - -$(PREFIX)/bin/mdboard : $(PREFIX)/bin/.$(ARCHSTR)/mdboard utils/mk_wrapper - utils/mk_wrapper $(PREFIX) mdboard $(PREFIX)/bin/mdboard - chmod a+x $(PREFIX)/bin/mdboard - -# $(HELPERS) : utils/% -# $(INSTALL) $< $@ -# chmod a+x $@ +# mtutil + +$(PREFIX)/bin/.$(ARCHSTR)/mtut : mtut + $(INSTALL) mtut $(PREFIX)/bin/.$(ARCHSTR)/mtut + +install-mtut : mtut + $(INSTALL) mtut $(PREFIX)/bin/mtut + +$(PREFIX)/bin/mtutil : $(PREFIX)/bin/.$(ARCHSTR)/mtut utils/mk_wrapper + utils/mk_wrapper $(PREFIX) mtut $(PREFIX)/bin/mtutil + chmod a+x $(PREFIX)/bin/mtutil + +# mtexec + +mtexec: $(OFILES) $(MOFILES) megatest-fossil-hash.scm mtexec.scm + csc $(CSCOPTS) $(OFILES) $(MOFILES) mtexec.scm -o mtexec + +$(PREFIX)/bin/.$(ARCHSTR)/mtexec : mtexec + $(INSTALL) mtexec $(PREFIX)/bin/.$(ARCHSTR)/mtexec + +$(PREFIX)/bin/mtexec : $(PREFIX)/bin/.$(ARCHSTR)/mtexec utils/mk_wrapper + utils/mk_wrapper $(PREFIX) mtexec $(PREFIX)/bin/mtexec + chmod a+x $(PREFIX)/bin/mtexec + +# tcmt + +$(PREFIX)/bin/.$(ARCHSTR)/tcmt : tcmt + $(INSTALL) tcmt $(PREFIX)/bin/.$(ARCHSTR)/tcmt + +$(PREFIX)/bin/tcmt : $(PREFIX)/bin/.$(ARCHSTR)/tcmt utils/mk_wrapper + utils/mk_wrapper $(PREFIX) tcmt $(PREFIX)/bin/tcmt + chmod a+x $(PREFIX)/bin/tcmt $(PREFIX)/bin/mt_laststep : utils/mt_laststep $(INSTALL) $< $@ chmod a+x $@ $(PREFIX)/bin/mt_runstep : utils/mt_runstep $(INSTALL) $< $@ chmod a+x $@ + +$(PREFIX)/bin/serialize-env: serialize-env.scm + csc serialize-env.scm + $(INSTALL) serialize-env $@ $(PREFIX)/bin/mt_ezstep : utils/mt_ezstep $(INSTALL) $< $@ chmod a+x $@ @@ -119,45 +276,84 @@ chmod a+x $@ $(PREFIX)/bin/nbfake : utils/nbfake $(INSTALL) $< $@ chmod a+x $@ + +$(PREFIX)/bin/remrun : utils/remrun + $(INSTALL) $< $@ + chmod a+x $@ + +$(PREFIX)/bin/viewscreen : utils/viewscreen + $(INSTALL) $< $@ + chmod a+x $@ $(PREFIX)/bin/nbfind : utils/nbfind $(INSTALL) $< $@ chmod a+x $@ -$(PREFIX)/bin/loadrunner : utils/loadrunner +$(PREFIX)/bin/mtrunner : utils/mtrunner + $(INSTALL) $< $@ + chmod a+x $@ + +deploytarg/nbfake : utils/nbfake $(INSTALL) $< $@ chmod a+x $@ -# $(PREFIX)/bin/refdb : refdb -# $(INSTALL) $< $@ -# chmod a+x $@ - -deploytarg/nbfake : utils/nbfake +deploytarg/viewscreen : utils/viewscreen $(INSTALL) $< $@ chmod a+x $@ deploytarg/nbfind : utils/nbfind $(INSTALL) $< $@ chmod a+x $@ +$(PREFIX)/bin/mtest-reaper: helpers/mtest-reaper.scm helpers/ducttape-lib.scm helpers/inteldate.scm helpers/mimetypes.scm + make -C helpers $@ PREFIX=$(PREFIX) INSTALL=$(INSTALL) ARCHSTR=$(ARCHSTR) + +mtest-reaper: $(PREFIX)/bin/mtest-reaper # install dashboard as dboard so wrapper script can be called dashboard $(PREFIX)/bin/.$(ARCHSTR)/dboard : dboard $(FILES) utils/mk_wrapper utils/mk_wrapper $(PREFIX) dboard $(PREFIX)/bin/dashboard chmod a+x $(PREFIX)/bin/dashboard $(INSTALL) dboard $(PREFIX)/bin/.$(ARCHSTR)/dboard + +# Work around missing libraries on crappy corporate compute farm (hearafter known as CCCF) +ifeq ($(ARCHSTR),12.5) +EXTRALIBS_HACK=$(PREFIX)/bin/.$(ARCHSTR)/lib/libpangox-1.0.so $(PREFIX)/bin/.$(ARCHSTR)/lib/libpangox-1.0.so.0 $(PREFIX)/bin/.$(ARCHSTR)/lib/libxcb-xlib.so.0 +else +EXTRALIBS_HACK= +endif + +$(PREFIX)/bin/.$(ARCHSTR)/lib/libpangox-1.0.so : lib/libpangox-1.0.so + mkdir -p $(PREFIX)/bin/.$(ARCHSTR)/lib + $(INSTALL) lib/libpangox-1.0.so $(PREFIX)/bin/.$(ARCHSTR)/lib/libpangox-1.0.so + +$(PREFIX)/bin/.$(ARCHSTR)/lib/libpangox-1.0.so.0 : lib/libpangox-1.0.so.0 + mkdir -p $(PREFIX)/bin/.$(ARCHSTR)/lib + $(INSTALL) lib/libpangox-1.0.so.0 $(PREFIX)/bin/.$(ARCHSTR)/lib/libpangox-1.0.so.0 + +$(PREFIX)/bin/.$(ARCHSTR)/lib/libxcb-xlib.so.0 : lib/libxcb-xlib.so.0 + mkdir -p $(PREFIX)/bin/.$(ARCHSTR)/lib + $(INSTALL) lib/libxcb-xlib.so.0 $(PREFIX)/bin/.$(ARCHSTR)/lib/libxcb-xlib.so.0 install : $(PREFIX)/bin/.$(ARCHSTR) $(PREFIX)/bin/.$(ARCHSTR)/mtest $(PREFIX)/bin/megatest \ $(PREFIX)/bin/.$(ARCHSTR)/dboard $(PREFIX)/bin/dashboard $(HELPERS) $(PREFIX)/bin/nbfake \ - $(PREFIX)/bin/nbfind $(PREFIX)/bin/loadrunner $(PREFIX)/bin/mt_xterm \ - $(PREFIX)/bin/newdashboard $(PREFIX)/bin/mdboard + $(PREFIX)/bin/.$(ARCHSTR)/mtexec $(PREFIX)/bin/mtexec $(PREFIX)/bin/serialize-env \ + $(PREFIX)/bin/nbfind $(PREFIX)/bin/mtrunner $(PREFIX)/bin/viewscreen $(PREFIX)/bin/mt_xterm \ + $(PREFIX)/share/docs/megatest_manual.html $(PREFIX)/bin/remrun \ + $(PREFIX)/share/docs/megatest_manual.html $(PREFIX)/bin/remrun $(PREFIX)/bin/mtutil \ + $(PREFIX)/bin/tcmt $(PREFIX)/share/db/mt-pg.sql \ + $(PREFIX)/share/js/jquery-3.1.0.slim.min.js \ + $(EXTRALIBS_HACK) + +# $(PREFIX)/bin/newdashboard $(PREFIX)/bin/.$(ARCHSTR) : mkdir -p $(PREFIX)/bin/.$(ARCHSTR) + mkdir -p $(PREFIX)/bin/.$(ARCHSTR)/lib test: tests/tests.scm cd tests;csi -I .. -b -n tests.scm ext-tests/.fslckout : $(MTQA_FOSSIL) @@ -166,11 +362,23 @@ $(MTQA_FOSSIL) : fossil clone https://www.kiatoa.com/fossils/megatest_qa $(MTQA_FOSSIL) clean : - rm -f $(OFILES) $(GOFILES) megatest dboard dboard.o megatest.o dashboard.o megatest-fossil-hash.* altdb.scm + rm -f $(OFILES) $(GOFILES) $(MOFILES) $(TCMTOBJS) \ + $(PREFIX)/megatest $(PREFIX)/dashboard mtest mtutil mtut \ + tcmt readline-fix.scm serialize-env dboard *.o \ + megatest-fossil-hash.* altdb.scm mofiles/*.o \ + mofiles/*.o vg.o cookie.o dashboard-main.o \ + ducttape-lib.o ftail.o mutils.o pkts.o rmtmod.o stml2.o \ + tcmt.o *.import.scm *.import.o + rm -f $(OFILES) $(GOFILES) $(MOFILES) $(TCMTOBJS) \ + $(PREFIX)/megatest $(PREFIX)/dashboard mtest mtutil mtut \ + tcmt ftail.import.scm readline-fix.scm serialize-env \ + dboard dboard.o megatest.o dashboard.o \ + megatest-fossil-hash.* altdb.scm mofiles/*.o vg.o + rm -rf share #====================================================================== # Make the records files #====================================================================== @@ -186,23 +394,11 @@ chmod a+X $@ deploytarg/apropos.so : Makefile chicken-install -p deploytarg -deploy -keep-installed $(EGGS) -# for i in apropos base64 canvas-draw csv-xml directory-utils dot-locking extras fmt format hostinfo http-client intarweb json md5 message-digest posix posix-extras readline regex regex-case s11n spiffy spiffy-request-vars sqlite3 srfi-1 srfi-18 srfi-69 tcp test uri-common check-errors synch matchable sql-null tcp-server rpc blob-utils string-utils variable-item defstruct uri-generic sendfile opensll openssl lookup-table list-utils stack; do \ -# chicken-install -prefix deploytarg -deploy $$i;done - -# deploytarg/libsqlite3.so : -# CSC_OPTIONS="-Ideploytarg -Ldeploytarg" $CHICKEN_INSTALL -prefix deploytarg -deploy sqlite3 - -deploy : deploytarg/mtest deploytarg/dboard $(DEPLOYHELPERS) deploytarg/nbfake deploytarg/nbfind deploytarg/apropos.so - -# deploytarg/libiupcd.so : $(CKPATH)/lib/libiupcd.so -# for i in iup im cd av call sqlite; do \ -# cp $(CKPATH)/lib/lib$$i* deploytarg/ ; \ -# done -# cp $(CKPATH)/include/*.h deploytarg +deploy : deploytarg/mtest deploytarg/dboard $(DEPLOYHELPERS) deploytarg/nbfake deploytarg/remrun deploytarg/viewsceen deploytarg/nbfind deploytarg/apropos.so # puts deployed megatest in directory "megatest" deploytarg/mtest : $(OFILES) megatest.o deploytarg/apropos.so csc -deploy $(CSCOPTS) $(OFILES) megatest.scm -o deploytarg mv deploytarg/deploytarg deploytarg/mtest @@ -209,12 +405,10 @@ deploytarg/dboard : $(OFILES) $(GOFILES) dashboard.scm deploytarg/apropos.so csc -deploy $(OFILES) $(GOFILES) dashboard.scm -o deploytarg mv deploytarg/deploytarg deploytarg/dboard -# DATASHAREO=configf.o common.o process.o tree.o dcommon.o margs.o launch.o gutils.o db.o synchash.o server.o \ -# megatest-version.o tdb.o ods.o mt.o keys.o datashare-testing/sd : datashare.scm $(OFILES) csc $(CSCOPTS) datashare.scm $(OFILES) -o datashare-testing/sd datashare-testing/sdat: sharedat.scm $(OFILES) csc $(CSCOPTS) sharedat.scm $(OFILES) -o datashare-testing/sdat @@ -223,26 +417,27 @@ mkdir -p /tmp/$(USER)/datashare/disk1 /tmp/$(USER)/basepath xterm : sd (export BASEPATH=/tmp/$(USER)/basepath ; export PATH="$(PWD)/datashare-testing:$(PATH)" ; xterm &) -datashare-testing/spublish : spublish.scm $(OFILES) - csc $(CSCOPTS) spublish.scm $(OFILES) -o datashare-testing/spublish - -datashare-testing/sretrieve : sretrieve.scm megatest-version.o margs.o configf.o process.o - csc $(CSCOPTS) sretrieve.scm megatest-version.o margs.o configf.o process.o -o datashare-testing/sretrieve - -sretrieve/sretrieve : datashare-testing/sretrieve - csc $(CSCOPTS) -deploy -deployed sretrieve.scm megatest-version.o margs.o configf.o process.o - chicken-install -keep-installed $(PROXY) -deploy -prefix sretrieve defstruct srfi-18 format sql-de-lite \ - srfi-1 posix regex regex-case srfi-69 - -# base64 dot-locking \ -# csv-xml z3 - -# "(define (toplevel-command . a) #f)" -# if egrep 'version.*3.0' $(shell dirname $(shell dirname $(shell which csi)))/lib/chicken/7/readline.setup-info;then \ +datashare-testing/spublish : spublish.scm $(OFILES) megatest-version.scm + csc $(CSCOPTS) spublish.scm margs.o process.o common.o -o datashare-testing/spublish + +datashare-testing/sretrieve : sretrieve.scm $(OFILES) megatest-version.scm + csc $(CSCOPTS) sretrieve.scm margs.o process.o common.o -o datashare-testing/sretrieve + + +datashare-testing/sauthorize : sauthorize.scm $(OFILES) megatest-version.scm + csc $(CSCOPTS) sauthorize.scm margs.o process.o common.o -o datashare-testing/sauthorize + +sauth-init: + mkdir -p datashare-testing + rm datashare-testing/sauthorize + rm datashare-testing/sretrieve + rm datashare-testing/spublish + +sauth : sauth-init datashare-testing/sauthorize datashare-testing/sretrieve datashare-testing/spublish readline-fix.scm : if [[ $(shell chicken-status | grep readline | awk '{print $4}' | cut -d. -f1) -gt 3 ]];then \ echo "(define *use-new-readline* #f)" > readline-fix.scm; \ else \ @@ -257,7 +452,28 @@ fi if csi -ne '(use postgresql)';then \ echo "(use postgresql)(hash-table-set! *available-db* 'postgresql #t)" >> altdb.scm;\ fi -portlogger-example : portlogger-example.scm api.o archive.o client.o common.o configf.o daemon.o dashboard-tests.o db.o dcommon.o ezsteps.o filedb.o genexample.o gutils.o http-transport.o items.o keys.o launch.o lock-queue.o margs.o megatest-version.o mt.o nmsg-transport.o ods.o portlogger.o process.o rmt.o rpc-transport.o runconfig.o runs.o sdb.o server.o synchash.o tasks.o tdb.o tests.o tree.o - csc $(CSCOPTS) portlogger-example.scm api.o archive.o client.o common.o configf.o daemon.o dashboard-tests.o db.o dcommon.o ezsteps.o filedb.o genexample.o gutils.o http-transport.o items.o keys.o launch.o lock-queue.o margs.o megatest-version.o mt.o nmsg-transport.o ods.o portlogger.o process.o rmt.o rpc-transport.o runconfig.o runs.o sdb.o server.o synchash.o tasks.o tdb.o tests.o tree.o +portlogger-example : portlogger-example.scm api.o archive.o client.o common.o configf.o dashboard-tests.o dashboard-context-menu.o db.o dcommon.o ezsteps.o filedb.o genexample.o gutils.o http-transport.o items.o keys.o launch.o lock-queue.o margs.o mt.o ods.o portlogger.o process.o rmt.o runconfig.o runs.o sdb.o server.o synchash.o tasks.o tdb.o tests.o tree.o + csc $(CSCOPTS) portlogger-example.scm api.o archive.o client.o common.o configf.o dashboard-tests.o dashboard-context-menu.o db.o dcommon.o ezsteps.o filedb.o genexample.o gutils.o http-transport.o items.o keys.o launch.o lock-queue.o margs.o mt.o ods.o portlogger.o process.o rmt.o runconfig.o runs.o sdb.o server.o synchash.o tasks.o tdb.o tests.o tree.o + +# create a pdf dot graphviz diagram from notations in rmt.scm +rmt.pdf : rmt.scm + grep ';;DOT' rmt.scm | sed -e 's/.*;;DOT //' > rmt.dot;dot -Tpdf rmt.dot -o rmt.pdf + +buildmanual: + cd docs/manual && make + +wikipage=plan +editwiki: + cd docs/manual && ../../utils/editwiki $(wikipage) + +viewmanual: + arora docs/manual/megatest_manual.html + +targets: + @grep : Makefile | perl -ne '/^([A-Za-z0-9_-]+):/ && print "$$1\n"' + + +unit : + cd tests;make unit ADDED Makefile.deploy Index: Makefile.deploy ================================================================== --- /dev/null +++ Makefile.deploy @@ -0,0 +1,465 @@ +# make install CSCOPTS='-accumulate-profile -profile-name $(PWD)/profile-ww$(shell date +%V.%u)' + +# Copyright 2006-2017, Matthew Welland. +# +# This file is part of Megatest. +# +# Megatest is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# Megatest is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with Megatest. If not, see . +# + +PREFIX=$(PWD) +CSCOPTS= -deploy +INSTALL=install +CHICKEN=$(shell which csc) +CHICKEN_BIN_DIR=$(shell dirname ${CHICKEN}/) +CHICKEN_DIR=${CHICKEN_BIN_DIR}/.. +SRCFILES = common.scm items.scm launch.scm \ + ods.scm runconfig.scm server.scm configf.scm \ + db.scm keys.scm margs.scm megatest-version.scm \ + process.scm runs.scm tasks.scm tests.scm genexample.scm \ + http-transport.scm filedb.scm tdb.scm \ + client.scm daemon.scm mt.scm \ + ezsteps.scm lock-queue.scm sdb.scm \ + rmt.scm api.scm subrun.scm \ + portlogger.scm archive.scm env.scm diff-report.scm cgisetup/models/pgdb.scm + +# module source files +MSRCFILES = ftail.scm + +# Eggs to install (straightforward ones) +EGGS=matchable readline apropos base64 regex-literals format regex-case test coops trace csv \ +dot-locking posix-utils posix-extras directory-utils hostinfo tcp-server rpc csv-xml fmt \ +json md5 awful http-client spiffy uri-common intarweb spiffy-request-vars \ +spiffy-directory-listing ssax sxml-serializer sxml-modifications iup canvas-draw sqlite3 + +GUISRCF = dashboard-tests.scm dashboard-guimonitor.scm gutils.scm dcommon.scm tree.scm vg.scm + +OFILES = $(SRCFILES:%.scm=%.o) +GOFILES = $(GUISRCF:%.scm=%.o) + +MOFILES = $(addprefix mofiles/,$(MSRCFILES:%.scm=%.o)) + +mofiles/%.o : %.scm + mkdir -p mofiles + csc $(CSCOPTS) -J -c $< -o mofiles/$*.o + +ADTLSCR=mt_laststep mt_runstep mt_ezstep +HELPERS=$(addprefix $(PREFIX)/bin/,$(ADTLSCR)) +DEPLOYHELPERS=$(addprefix deploytarg/,$(ADTLSCR)) +MTESTHASH=$(shell fossil info|grep checkout:| awk '{print $$2}') + +CSIPATH=$(shell which csi) +CKPATH=$(shell dirname $(shell dirname $(CSIPATH))) +# ARCHSTR=$(shell uname -m)_$(shell uname -r) +# BASH_MACHTYPE=$(shell bash -c "echo \$$MACHTYPE") +# ARCHSTR=$(BASH_MACHTYPE)_$(shell lsb_release -sr) +ARCHSTR=$(shell lsb_release -sr) +# ARCHSTR=$(shell bash -c "echo \$$MACHTYPE") + +PNGFILES = $(shell cd docs/manual;ls *png) + +ARCHSIZE=64_ +IMVER=3.11 +IUPVER=3.17 +KTYPE=26g4 +CDVER=5.10 + +all : $(PREFIX)/bin/.$(ARCHSTR) postgres nanomsg mtest dboard mtut eggs sqlite matt iup wrappers + +mtest: $(OFILES) readline-fix.scm megatest.o $(MOFILES) mofiles/ftail.o + mkdir -p $(PREFIX)/deploy + csc $(CSCOPTS) $(OFILES) $(MOFILES) megatest.o -o $(PREFIX)/deploy/mtest + cp $(CKPATH)/lib/chicken/7/chicken.import.so $(PREFIX)/deploy/mtest + cp $(CKPATH)/lib/chicken/7/foreign.import.so $(PREFIX)/deploy/mtest + cp $(CKPATH)/lib/chicken/7/ports.import.so $(PREFIX)/deploy/mtest + cp $(CKPATH)/lib/chicken/7/data-structures.import.so $(PREFIX)/deploy/mtest + cp $(CKPATH)/lib/chicken/7/posix.import.so $(PREFIX)/deploy/mtest + cp $(CKPATH)/lib/chicken/7/irregex.import.so $(PREFIX)/deploy/mtest + +eggs: $(PREFIX)/deploy/mtest/fmt.so + +$(PREFIX)/deploy/mtest/fmt.so: + chicken-install -deploy -p $(PREFIX)/deploy/mtest base64 format regex-case simple-exceptions typed-records apropos directory-utils spiffy http-client spiffy-request-vars spiffy-directory-listing posix-extras call-with-environment-variables csv typed-records pathname-expand json crypt dot-locking csv-xml:0.10.2 z3 sql-de-lite hostinfo rpc directory-utils spiffy http-client spiffy-request-vars spiffy-directory-listing posix-extras call-with-environment-variables rpc fmt md5:3.1.0 check-errors:1.13.0 string-utils:1.2.4 message-digest:3.1.1 csv-xml:0.10.2 sha1 ansi-escape-sequences test slice rfc3339 uuid-lib filepath srfi-19:3.3.6 readline trace lolevel + cd utils/opensrc/mutils && chicken-install -deploy -p $(PREFIX)/deploy/mtest + cd ducttape && chicken-install -deploy -p $(PREFIX)/deploy/mtest + cp $(CHICKEN_DIR)/lib/chicken/7/chicken.import.so $(PREFIX)/deploy/mtest/ + cp $(CHICKEN_DIR)/lib/chicken/7/foreign* $(PREFIX)/deploy/mtest/ + cp $(CHICKEN_DIR)/lib/chicken/7/ports.import.so $(PREFIX)/deploy/mtest/ + cp $(CHICKEN_DIR)/lib/chicken/7/data-structures.import.so $(PREFIX)/deploy/mtest/ + cp $(CHICKEN_DIR)/lib/chicken/7/posix.import.so $(PREFIX)/deploy/mtest/ + cp $(CHICKEN_DIR)/lib/chicken/7/irregex.import.so $(PREFIX)/deploy/mtest/ + + +sqlite: $(PREFIX)/deploy/mtest/sqlite3.so + +$(PREFIX)/deploy/mtest/sqlite3.so: + wget http://www.sqlite.org/2015/sqlite-autoconf-3090200.tar.gz + tar xfz sqlite-autoconf-3090200.tar.gz + cd sqlite-autoconf-3090200 + cd sqlite-autoconf-3090200 && ./configure --prefix=$(PREFIX)/deploy/mtest + cd sqlite-autoconf-3090200 && make + cd sqlite-autoconf-3090200 && make install + CSC_OPTIONS='-I$(PREFIX)/deploy/mtest/include -L$(PREFIX)/deploy/mtest/' chicken-install -deploy -p $(PREFIX)/deploy/mtest sqlite3 check-errors:1.13.0 + +matt: $(PREFIX)/deploy/mtest/stml.so + +$(PREFIX)/deploy/mtest/stml.so: + wget -c -O stml.tar.gz 'http://www.kiatoa.com/fossils/stml/tarball?name=stml&uuid=trunk' + tar -xzf stml.tar.gz + cd stml && cp install.cfg.template install.cfg + cd stml && echo "TARGDIR=`realpath $(PREFIX)/deploy/mtest`" > install.cfg + cd stml && echo "LOGDIR=/tmp/stmlrun" >> install.cfg + cd stml && echo "SQLITE3=$PREFIX/bin/sqlite3" >> install.cfg + cd stml && cp requirements.scm.template requirements.scm + cd stml && make clean + -cd stml && CSCOPTS="-C -fPIC" make + cd stml && chicken-install -deploy -p $(PREFIX)/deploy/mtest + wget -c -O opensrc.tar.gz 'http://www.kiatoa.com/fossils/opensrc/tarball?name=opensrc&uuid=trunk' + tar -xzf opensrc.tar.gz + cd opensrc/mutils && chicken-install -deploy -p $(PREFIX)/deploy/mtest + cd opensrc/dbi && chicken-install -deploy -p $(PREFIX)/deploy/mtest + cd opensrc/margs && chicken-install -deploy -p $(PREFIX)/deploy/mtest + cd opensrc/pkts && chicken-install -deploy -p $(PREFIX)/deploy/mtest + +nanomsg: $(PREFIX)/deploy/mtest/libnanomsg.so.1.0.0 + +$(PREFIX)/deploy/mtest/libnanomsg.so.1.0.0: + wget --no-check-certificate https://github.com/nanomsg/nanomsg/archive/1.0.0.tar.gz + mv 1.0.0 1.0.0.tar.gz + tar xf 1.0.0.tar.gz + cd nanomsg-1.0.0 && ./configure --prefix=$(PREFIX)/deploy/mtest + cd nanomsg-1.0.0 && make + cd nanomsg-1.0.0 && make install + CSC_OPTIONS="-I$(PREFIX)/deploy/mtest/include -L$(PREFIX)/deploy/mtest/lib -L$(PREFIX)/deploy/mtest/lib64/" chicken-install -deploy -p $(PREFIX)/deploy/mtest nanomsg + +$(PREFIX)/deploy/mtest/bin/pg_config: + wget -c https://ftp.postgresql.org/pub/source/v9.6.4/postgresql-9.6.4.tar.gz + tar xfz postgresql-9.6.4.tar.gz + cd postgresql-9.6.4 && ./configure --prefix=$(PREFIX)/deploy/mtest/ --with-openssl; + cd postgresql-9.6.4 && make + cd postgresql-9.6.4 && make install + +$(PREFIX)/deploy/mtest/postgresql.so: + CSC_OPTIONS="-I$(PREFIX)/deploy/mtest/include -L$(PREFIX)/deploy/mtest/lib -L$(PREFIX)/deploy/mtest/lib64/" chicken-install -deploy -p $(PREFIX)/deploy/mtest postgresql + +postgres: $(PREFIX)/deploy/mtest/bin/pg_config $(PREFIX)/deploy/mtest/postgresql.so + +ducttape: $(PREFIX)/deploy/mtest/ducttape.so + +$(PREFIX)/deploy/mtest/ducttape.so: + cd ducttape && chicken-install -p $(PREFIX)/deploy/mtest -deploy + +iup: $(PREFIX)/deploy/mtest/iup.so + +$(PREFIX)/deploy/mtest/iup.so: + wget -c http://www.kiatoa.com/matt/chicken-build/cd/cd-${CDVER}_Linux${KTYPE}_${ARCHSIZE}lib.tar.gz + wget -c http://www.kiatoa.com/matt/chicken-build/im/im-${IMVER}_Linux${KTYPE}_${ARCHSIZE}lib.tar.gz + wget -c http://www.kiatoa.com/matt/chicken-build/iup/iup-${IUPVER}_Linux${KTYPE}_${ARCHSIZE}lib.tar.gz + tar -xzvf cd-${CDVER}_Linux${KTYPE}_${ARCHSIZE}lib.tar.gz -C $(PREFIX)/deploy/mtest/ + tar -xzvf im-${IMVER}_Linux${KTYPE}_${ARCHSIZE}lib.tar.gz -C $(PREFIX)/deploy/mtest/ + tar -xzvf iup-${IUPVER}_Linux${KTYPE}_${ARCHSIZE}lib.tar.gz -C $(PREFIX)/deploy/mtest/ + cp $(PREFIX)/deploy/mtest/ftgl/lib/*/* $(PREFIX)/deploy/mtest/ + wget -c -O ffcall.tar.gz 'http://www.kiatoa.com/fossils/ffcall/tarball?name=ffcall&uuid=trunk' + tar -xzf ffcall.tar.gz + cd ffcall && ./configure --prefix=$(PREFIX)/deploy/mtest/ --enable-shared + cd ffcall && make CC="gcc -fPIC" + cd ffcall && make install + CSC_OPTIONS="-I$(PREFIX)/include -I$(PREFIX)/deploy/mtest/include -L$(PREFIX)/deploy/mtest" chicken-install -deploy -p $(PREFIX)/deploy/mtest -D no-library-checks -feature disable-iup-web iup + CSC_OPTIONS="-I$(PREFIX)/include -I$(PREFIX)/deploy/mtest//include -L$(PREFIX)/deploy/mtest" chicken-install -deploy -p $(PREFIX)/deploy/mtest -D no-library-checks canvas-draw + +dboard: $(OFILES) $(GOFILES) dashboard.scm $(MOFILES) + csc $(CSCOPTS) $(OFILES) dashboard.scm $(GOFILES) $(MOFILES) -o $(PREFIX)/deploy/mtest/dboard2 + cp $(PREFIX)/deploy/mtest/dboard2/dboard2 $(PREFIX)/deploy/mtest/dboard + +ndboard : newdashboard.scm $(OFILES) $(GOFILES) + csc $(CSCOPTS) $(OFILES) $(GOFILES) newdashboard.scm -o $(PREFIX)/deploy/mtest/newdboard + +mtut : $(OFILES) megatest-fossil-hash.scm mtut.scm + csc $(CSCOPTS) $(OFILES) mtut.scm -o $(PREFIX)/deploy/mtest/mtut + +# install documentation to $(PREFIX)/docs +# DOES NOT REBUILD DOCS +# +$(PREFIX)/share/docs/megatest_manual.html : docs/manual/megatest_manual.html + mkdir -p $(PREFIX)/share/docs + $(INSTALL) docs/manual/megatest_manual.html $(PREFIX)/share/docs/megatest_manual.html + for png in $(PNGFILES);do $(INSTALL) docs/manual/$$png $(PREFIX)/share/docs/$$png;done + +js : java-script-lib/jquery-3.1.0.slim.min.js + mkdir -p $(PREFIX)/share/js + cp java-script-lib/jquery-3.1.0.slim.min.js $(PREFIX)/share/js/jquery-3.1.0.slim.min.js + +$(PREFIX)/share/db/mt-pg.sql : mt-pg.sql + mkdir -p $(PREFIX)/share/db + $(INSTALL) mt-pg.sql $(PREFIX)/share/db/mt-pg.sql + +#multi-dboard : multi-dboard.scm $(OFILES) $(GOFILES) +# csc $(CSCOPTS) $(OFILES) $(GOFILES) multi-dboard.scm -o multi-dboard + +# +# $(PREFIX)/bin/revtagfsl : utils/revtagfsl.scm +# csc utils/revtagfsl.scm -o $(PREFIX)/bin/revtagfsl + +# Special dependencies for the includes +tests.o db.o launch.o runs.o dashboard-tests.o dashboard-guimonitor.o dashboard-main.o monitor.o dashboard.o \ +archive.o megatest.o : db_records.scm +tests.o runs.o dashboard.o dashboard-tests.o dashboard-main.o : run_records.scm +db.o ezsteps.o keys.o launch.o megatest.o monitor.o runs-for-ref.o runs.o tests.o : key_records.scm +tests.o tasks.o dashboard-tasks.o : task_records.scm +runs.o : test_records.scm +megatest.o : megatest-fossil-hash.scm +client.scm common.scm configf.scm dashboard-guimonitor.scm dashboard-tests.scm dashboard.scm db.scm dcommon.scm ezsteps.scm fs-transport.scm http-transport.scm index-tree.scm items.scm keys.scm launch.scm megatest.scm monitor.scm mt.scm newdashboard.scm runconfig.scm runs.scm server.scm tdb.scm tests.scm tree.scm : common_records.scm rpc-transport.scm +common_records.scm : altdb.scm +vg.o dashboard.o : vg_records.scm +dcommon.o : run_records.scm +# Temporary while transitioning to new routine +# runs.o : run-tests-queue-classic.scm run-tests-queue-new.scm + +megatest-fossil-hash.scm : $(SRCFILES) megatest.scm *_records.scm + echo "(define megatest-fossil-hash \"$(MTESTHASH)\")" > megatest-fossil-hash.new + if ! diff -q megatest-fossil-hash.new megatest-fossil-hash.scm ; then echo copying .new to .scm;cp -f megatest-fossil-hash.new megatest-fossil-hash.scm;fi + +$(OFILES) $(GOFILES) : common_records.scm + +%.o : %.scm + csc $(CSCOPTS) -c $< + +$(PREFIX)/bin/.$(ARCHSTR)/mtest : mtest utils/mk_wrapper + @echo Installing to PREFIX=$(PREFIX) + $(INSTALL) mtest $(PREFIX)/bin/.$(ARCHSTR)/mtest + utils/mk_wrapper $(PREFIX) mtest $(PREFIX)/bin/megatest + chmod a+x $(PREFIX)/bin/megatest + +$(PREFIX)/bin/.$(ARCHSTR)/ndboard : ndboard + $(INSTALL) ndboard $(PREFIX)/bin/.$(ARCHSTR)/ndboard + +$(PREFIX)/bin/.$(ARCHSTR)/mtut : mtut + $(INSTALL) mtut $(PREFIX)/bin/.$(ARCHSTR)/mtut + +install-mtut : mtut + echo $(INSTALL) + #$(INSTALL) mtut $(PREFIX)/bin/mtut + +$(PREFIX)/bin/mtutil : $(PREFIX)/bin/.$(ARCHSTR)/mtut utils/mk_wrapper + utils/mk_wrapper $(PREFIX) mtut $(PREFIX)/bin/mtutil + chmod a+x $(PREFIX)/bin/mtutil + +mtutil: $(PREFIX)/bin/mtutil + +$(PREFIX)/bin/newdashboard : $(PREFIX)/bin/.$(ARCHSTR)/ndboard utils/mk_wrapper + utils/mk_wrapper $(PREFIX) ndboard $(PREFIX)/bin/newdashboard + chmod a+x $(PREFIX)/bin/newdashboard + +#$(PREFIX)/bin/.$(ARCHSTR)/mdboard : multi-dboard +# $(INSTALL) multi-dboard $(PREFIX)/bin/.$(ARCHSTR)/mdboard + +# $(PREFIX)/bin/mdboard : $(PREFIX)/bin/.$(ARCHSTR)/mdboard utils/mk_wrapper +# utils/mk_wrapper $(PREFIX) mdboard $(PREFIX)/bin/mdboard +# chmod a+x $(PREFIX)/bin/mdboard + +# $(HELPERS) : utils/% +# $(INSTALL) $< $@ +# chmod a+x $@ + +$(PREFIX)/bin/mt_laststep : utils/mt_laststep + $(INSTALL) $< $@ + chmod a+x $@ + +$(PREFIX)/bin/mt_runstep : utils/mt_runstep + $(INSTALL) $< $@ + chmod a+x $@ + +$(PREFIX)/bin/mt_ezstep : utils/mt_ezstep + $(INSTALL) $< $@ + chmod a+x $@ + +$(PREFIX)/bin/mt_xterm : utils/mt_xterm + $(INSTALL) $< $@ + chmod a+x $@ + +$(PREFIX)/bin/nbfake : utils/nbfake + $(INSTALL) $< $@ + chmod a+x $@ + +$(PREFIX)/bin/viewscreen : utils/viewscreen + $(INSTALL) $< $@ + chmod a+x $@ + +$(PREFIX)/bin/nbfind : utils/nbfind + $(INSTALL) $< $@ + chmod a+x $@ + +$(PREFIX)/bin/loadrunner : utils/loadrunner + $(INSTALL) $< $@ + chmod a+x $@ + +$(PREFIX)/bin/mtest-reaper: helpers/mtest-reaper.scm helpers/ducttape-lib.scm helpers/inteldate.scm helpers/mimetypes.scm + make -C helpers $@ PREFIX=$(PREFIX) INSTALL=$(INSTALL) ARCHSTR=$(ARCHSTR) + +mtest-reaper: $(PREFIX)/bin/mtest-reaper + +# $(PREFIX)/bin/refdb : refdb +# $(INSTALL) $< $@ +# chmod a+x $@ + +deploytarg/nbfake : utils/nbfake + $(INSTALL) $< $@ + chmod a+x $@ + +deploytarg/viewscreen : utils/viewscreen + $(INSTALL) $< $@ + chmod a+x $@ + +deploytarg/nbfind : utils/nbfind + $(INSTALL) $< $@ + chmod a+x $@ + +# install dashboard as dboard so wrapper script can be called dashboard +$(PREFIX)/bin/.$(ARCHSTR)/dboard : dboard $(FILES) utils/mk_wrapper + utils/mk_wrapper $(PREFIX) dboard $(PREFIX)/bin/dashboard + chmod a+x $(PREFIX)/bin/dashboard + $(INSTALL) dboard $(PREFIX)/bin/.$(ARCHSTR)/dboard + +install : $(PREFIX)/bin/.$(ARCHSTR) $(PREFIX)/bin/.$(ARCHSTR)/mtest $(PREFIX)/bin/megatest \ + $(PREFIX)/bin/.$(ARCHSTR)/dboard $(PREFIX)/bin/dashboard $(HELPERS) $(PREFIX)/bin/nbfake \ + $(PREFIX)/bin/nbfind $(PREFIX)/bin/loadrunner $(PREFIX)/bin/viewscreen $(PREFIX)/bin/mt_xterm \ + $(PREFIX)/share/docs/megatest_manual.html $(PREFIX)/bin/remrun \ + $(PREFIX)/share/docs/megatest_manual.html $(PREFIX)/bin/remrun $(PREFIX)/bin/mtutil \ + $(PREFIX)/bin/tcmt $(PREFIX)/share/db/mt-pg.sql \ + js + + +$(PREFIX)/bin/.$(ARCHSTR) : + mkdir -p $(PREFIX)/bin/.$(ARCHSTR) + mkdir -p $(PREFIX)/bin/.$(ARCHSTR)/lib + +test: tests/tests.scm + cd tests;csi -I .. -b -n tests.scm + +ext-tests/.fslckout : $(MTQA_FOSSIL) + mkdir -p ext-tests + cd ext-tests;fossil open --nested $(MTQA_FOSSIL) + +$(MTQA_FOSSIL) : + fossil clone https://www.kiatoa.com/fossils/megatest_qa $(MTQA_FOSSIL) + +clean : + rm -f $(OFILES) $(GOFILES) megatest dboard dboard.o megatest.o dashboard.o megatest-fossil-hash.* altdb.scm + +#====================================================================== +# Make the records files +#====================================================================== + +# vg_records.scm : records.sh +# ./records.sh + +#====================================================================== +# Deploy section (not complete yet) +#====================================================================== + +$(DEPLOYHELPERS) : utils/mt_* + $(INSTALL) $< $@ + chmod a+X $@ + +deploytarg/apropos.so : Makefile + for egg in $(EGGS); do \ + echo "chicken-install -p deploytarg -deploy -keep-installed $$egg "; \ + chicken-install -p deploytarg -deploy -keep-installed $$egg ; \ + done +# for i in apropos base64 canvas-draw csv-xml directory-utils dot-locking extras fmt format hostinfo http-client intarweb json md5 message-digest posix posix-extras readline regex regex-case s11n spiffy spiffy-request-vars sqlite3 srfi-1 srfi-18 srfi-69 tcp test uri-common check-errors synch matchable sql-null tcp-server rpc blob-utils string-utils variable-item defstruct uri-generic sendfile opensll openssl lookup-table list-utils stack; do \ +# chicken-install -prefix deploytarg -deploy $$i;done + +# deploytarg/libsqlite3.so : +# CSC_OPTIONS="-Ideploytarg -Ldeploytarg" $CHICKEN_INSTALL -prefix deploytarg -deploy sqlite3 + +deploy : deploytarg/mtest deploytarg/dboard $(DEPLOYHELPERS) deploytarg/nbfake deploytarg/remrun deploytarg/viewsceen deploytarg/nbfind deploytarg/apropos.so + +# deploytarg/libiupcd.so : $(CKPATH)/lib/libiupcd.so +# for i in iup im cd av call sqlite; do \ +# cp $(CKPATH)/lib/lib$$i* deploytarg/ ; \ +# done +# cp $(CKPATH)/include/*.h deploytarg + +# puts deployed megatest in directory "megatest" +deploytarg/mtest : $(OFILES) megatest.o deploytarg/apropos.so + csc -deploy $(CSCOPTS) $(OFILES) megatest.scm -o deploytarg + mv deploytarg/deploytarg deploytarg/mtest + +deploytarg/dboard : $(OFILES) $(GOFILES) dashboard.scm deploytarg/apropos.so + csc -deploy $(OFILES) $(GOFILES) dashboard.scm -o deploytarg + mv deploytarg/deploytarg deploytarg/dboard + +# DATASHAREO=configf.o common.o process.o tree.o dcommon.o margs.o launch.o gutils.o db.o synchash.o server.o \ +# megatest-version.o tdb.o ods.o mt.o keys.o +datashare-testing/sd : datashare.scm $(OFILES) + csc $(CSCOPTS) datashare.scm $(OFILES) -o datashare-testing/sd + +datashare-testing/sdat: sharedat.scm $(OFILES) + csc $(CSCOPTS) sharedat.scm $(OFILES) -o datashare-testing/sdat + +sd : datashare-testing/sd + mkdir -p /tmp/$(USER)/datashare/disk1 /tmp/$(USER)/basepath + +xterm : sd + (export BASEPATH=/tmp/$(USER)/basepath ; export PATH="$(PWD)/datashare-testing:$(PATH)" ; xterm &) + +datashare-testing/spublish : spublish.scm $(OFILES) + csc $(CSCOPTS) spublish.scm $(OFILES) -o datashare-testing/spublish + +datashare-testing/sretrieve : sretrieve.scm megatest-version.o margs.o configf.o process.o + csc $(CSCOPTS) sretrieve.scm megatest-version.o margs.o configf.o process.o -o datashare-testing/sretrieve + +sretrieve/sretrieve : datashare-testing/sretrieve + csc $(CSCOPTS) -deploy -deployed sretrieve.scm megatest-version.o margs.o configf.o process.o + chicken-install -keep-installed $(PROXY) -deploy -prefix sretrieve defstruct srfi-18 format sql-de-lite \ + srfi-1 posix regex regex-case srfi-69 + +# base64 dot-locking \ +# csv-xml z3 + +# "(define (toplevel-command . a) #f)" +# if egrep 'version.*3.0' $(shell dirname $(shell dirname $(shell which csi)))/lib/chicken/7/readline.setup-info;then \ + +readline-fix.scm : + if [[ $(shell chicken-status | grep readline | awk '{print $4}' | cut -d. -f1) -gt 3 ]];then \ + echo "(define *use-new-readline* #f)" > readline-fix.scm; \ + else \ + echo "(define *use-new-readline* #t)" > readline-fix.scm;\ + fi + +altdb.scm : + echo ";; optional alternate db setup" > altdb.scm + echo "(define *available-db* (make-hash-table))" >> altdb.scm + if csi -ne '(use mysql-client)';then \ + echo "(use mysql-client)(hash-table-set! *available-db* 'mysql #t)" >> altdb.scm; \ + fi +# if csi -ne '(use postgresql)';then \ +# echo "(use postgresql)(hash-table-set! *available-db* 'postgresql #t)" >> altdb.scm;\ +# fi + +portlogger-example : portlogger-example.scm api.o archive.o client.o common.o configf.o daemon.o dashboard-tests.o db.o dcommon.o ezsteps.o filedb.o genexample.o gutils.o http-transport.o items.o keys.o launch.o lock-queue.o margs.o megatest-version.o mt.o ods.o portlogger.o process.o rmt.o rpc-transport.o runconfig.o runs.o sdb.o server.o synchash.o tasks.o tdb.o tests.o tree.o + csc $(CSCOPTS) portlogger-example.scm api.o archive.o client.o common.o configf.o daemon.o dashboard-tests.o db.o dcommon.o ezsteps.o filedb.o genexample.o gutils.o http-transport.o items.o keys.o launch.o lock-queue.o margs.o megatest-version.o mt.o ods.o portlogger.o process.o rmt.o rpc-transport.o runconfig.o runs.o sdb.o server.o synchash.o tasks.o tdb.o tests.o tree.o + +# create a pdf dot graphviz diagram from notations in rmt.scm +rmt.pdf : rmt.scm + grep ';;DOT' rmt.scm | sed -e 's/.*;;DOT //' > rmt.dot;dot -Tpdf rmt.dot -o rmt.pdf + +wrappers: wrappers/cfg.sh wrappers/megatest wrappers/dashboard + mkdir $(PREFIX)/deploy/mtest/.$(ARCHSTR) -p + cat wrappers/cfg.sh | sed 's#PREFIX#$(PREFIX)\/deploy\/mtest#g' > $(PREFIX)/deploy/mtest/.$(ARCHSTR)/cfg.sh + cat wrappers/megatest | sed 's#PREFIX#$(PREFIX)\/deploy\/mtest#g' | sed 's#ARCHSTR#.$(ARCHSTR)#g' > $(PREFIX)/deploy/mtest/megatest + cat wrappers/dashboard | sed 's#PREFIX#$(PREFIX)\/deploy\/mtest#g'| sed 's#ARCHSTR#.$(ARCHSTR)#g' > $(PREFIX)/deploy/mtest/dashboard + chmod +x $(PREFIX)/deploy/mtest/megatest + chmod +x $(PREFIX)/deploy/mtest/dashboard + Index: NOTES ================================================================== --- NOTES +++ NOTES @@ -1,13 +1,41 @@ +# Copyright 2006-2017, Matthew Welland. +# +# This file is part of Megatest. +# +# Megatest is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# Megatest is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with Megatest. If not, see . + +(server:writable-watchdog-bruteforce dbstruct) + +(server:writable-watchdog-deltasync dbstruct) + + +===================================================================== +NOTES from looking at branch v1.62-rpc +===================================================================== + +*last-db-access* or *db-last-access* ==> which is it to be? +seen in singletest: ERROR: Unrecognised arguments: :first_err This is the first error ====================================================================== New way of launching needed to accomodate different target hosttypes for items ====================================================================== [flavors] -general ssh #{getbgesthost general} +general ssh #{getbesthost general} nbgeneral nbjob run JOBCOMMAND -log $MT_LINKTREE/$MT_TARGET/$MT_RUNNAME.$MT_TESTNAME-$MT_ITEM_PATH.lgo [hosts] general cubian xena @@ -135,5 +163,9 @@ INFO: (0) Server shutdown complete. Exiting Start: 0 at Sun Apr 28 22:18:25 MST 2013 Max: 52 at Sun Apr 28 23:06:59 MST 2013 End: 6 at Sun Apr 28 23:47:51 MST 2013 + +======================================================================== + + Index: README ================================================================== --- README +++ README @@ -1,9 +1,26 @@ +# Copyright 2006-2017, Matthew Welland. +# +# This file is part of Megatest. +# +# Megatest is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# Megatest is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with Megatest. If not, see . + Megatest To build: -1. Install chicken scheme. See utils/Makefile.installall +1. Install chicken scheme. See opensrc repo utils/installall.sh http://www.kiatoa.com/fossils/opensrc 2. Compile with "make -j install PREFIX=/some/path" 3. To test .... Index: TODO ================================================================== --- TODO +++ TODO @@ -1,16 +1,64 @@ +# Copyright 2006-2020, Matthew Welland. +# +# This file is part of Megatest. +# +# Megatest is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# Megatest is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with Megatest. If not, see . + +TODO +==== + +WW38 +. Add test_rundat to no-sync ==> correction, put in /.meta/test-run.dat +. Add STATE/STATUS transitions to .meta/test-run.dat or similar +. Swizzle update-test-rundat to operate on no-sync +. Swizzle update-run-duration, -uname-host and cpuload-diskfree to no-sync +. On state/status change update tests table with duration + +WW15 +. fill newview matrix with data, filter pipeline gui elements +. improve [script], especially indent handling + +WW16 +. split db into megatest.db (runs etc.) db/.db +. release basic newview implementation + +WW18 +. release split db implementation +. mtutil calls from dashboard (for remote control) +. logs browser (esp. for surfacing mtutil related activities) + +WW19 +. break command line into sections; all, run control, queries, utilities etc. +. pull in ftfplan (not integrated, just code pulled in) -TODO -==== +WW20 +. ./configure => ubuntu, sles11, sles12, rh7 +. Add output flushing in teamcity support +. Switch to using simple runs query everywhere +. Add end_time to runs and add a rollup call that sets state, status and end_time -. Dashboard should resist running from non-homehost - - +Future +. Switch to scsh-process pipeline management for job execution/control +. Use call-with-environment-variables more. Migration to inmem db plus per run db ------------------------------------- . Re-work the dbstruct data structure? .. Move main.db to global? .. [ run-id.db inmemdb last-mod last-read last-sync inuse ] . Re-work all queries to use run-id to dereference server . Open main.db directly in calls to -runtests etc. No need to talk remote? +. remove common:faux-lock + ADDED adjutant.scm Index: adjutant.scm ================================================================== --- /dev/null +++ adjutant.scm @@ -0,0 +1,44 @@ +;;====================================================================== +;; Copyright 2017, Matthew Welland. +;; +;; This file is part of Megatest. +;; +;; Megatest is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. +;; +;; Megatest is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with Megatest. If not, see . + +;;====================================================================== + +(declare (unit adjutant)) + +(module adjutant * + +(import scheme chicken data-structures extras files) +(import (prefix sqlite3 sqlite3:) posix typed-records srfi-18 srfi-69 + md5 message-digest matchable + regex srfi-1) + +(define (adjutant-run host-type rmt:no-sync-take-job) + (print "Running the adjutant!") + (let loop ((wait-count 0)) + (if (< wait-count 10) ;; 6 x 10 seconds = one minute + (let* ((dat (rmt:no-sync-take-job host-type))) + (match dat + ((id ht vars exekey cmdline state event-time last-update) + (system cmdline) + (loop 0)) + (else + (thread-sleep! 10) + (loop (+ wait-count 1))))) + (print "I'm bored. Exiting.")))) + +) Index: api.scm ================================================================== --- api.scm +++ api.scm @@ -1,15 +1,26 @@ ;;====================================================================== ;; Copyright 2006-2013, Matthew Welland. ;; -;; This program is made available under the GNU GPL version 2.0 or -;; greater. See the accompanying file COPYING for details. +;; This file is part of Megatest. +;; +;; Megatest is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. +;; +;; Megatest is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. ;; -;; This program is distributed WITHOUT ANY WARRANTY; without even the -;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR -;; PURPOSE. +;; You should have received a copy of the GNU General Public License +;; along with Megatest. If not, see . +;; ;;====================================================================== + +(use srfi-69 posix) (declare (unit api)) (declare (uses rmt)) (declare (uses db)) (declare (uses tasks)) @@ -16,13 +27,17 @@ ;; allow these queries through without starting a server ;; (define api:read-only-queries '(get-key-val-pairs + get-var get-keys + get-key-vals test-toplevel-num-items get-test-info-by-id + get-steps-info-by-id + get-data-info-by-id test-get-rundir-from-test-id get-count-tests-running-for-testname get-count-tests-running get-count-tests-running-in-jobgroup get-previous-test-run-record @@ -34,43 +49,61 @@ test-get-paths-matching-keynames-target-new get-prereqs-not-met get-count-tests-running-for-run-id get-run-info get-run-status - register-run + get-run-state + get-run-stats + get-run-times + get-targets + get-target + ;; register-run + get-tests-tags + get-test-times get-tests-for-run + get-tests-for-run-state-status get-test-id get-tests-for-runs-mindata + get-tests-for-run-mindata get-run-name-from-id get-runs + simple-get-runs get-num-runs + get-runs-cnt-by-patt get-all-run-ids get-prev-run-ids get-run-ids-matching-target get-runs-by-patt get-steps-data get-steps-for-test read-test-data + read-test-data* login + tasks-get-last testmeta-get-record have-incompletes? - synchash-get - )) + ;; synchash-get + get-changed-record-ids + get-run-record-ids + get-not-completed-cnt)) (define api:write-queries '( + get-keys-write ;; dummy "write" query to force server start + ;; SERVERS start-server kill-server ;; TESTS test-set-state-status-by-id delete-test-records delete-old-deleted-test-records - test-set-status-state + test-set-state-status test-set-top-process-pid - roll-up-pass-fail-counts + set-state-status-and-roll-up-items + update-pass-fail-counts top-test-set-per-pf-counts ;; (db:top-test-set-per-pf-counts (db:get-db *db* 5) 5 "runfirst") ;; RUNS register-run @@ -77,20 +110,23 @@ set-tests-state-status delete-run lock/unlock-run update-run-event_time mark-incomplete - + set-state-status-and-roll-up-run ;; STEPS teststep-set-status! - + delete-steps-for-test ;; TEST DATA test-data-rollup csv->test-data ;; MISC sync-inmem->db + drop-all-triggers + create-all-triggers + update-tesdata-on-repilcate-db ;; TESTMETA testmeta-add-record testmeta-update-field @@ -106,169 +142,261 @@ ;; (define (api:execute-requests dbstruct dat) (handle-exceptions exn (let ((call-chain (get-call-chain))) + (debug:print 0 *default-log-port* "WARNING: api:execute-requests received an exception from peer, dat=" dat ", exn=" exn) (print-call-chain (current-error-port)) - (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) + (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) (vector #f (vector exn call-chain dat))) ;; return some stuff for debug if an exception happens - (if (not (vector? dat)) ;; it is an error to not receive a vector - (vector #f #f "remote must be called with a vector") - (vector ;; return a vector + the returned data structure - #t - (let ((cmd (vector-ref dat 0)) - (params (vector-ref dat 1))) - (case (if (symbol? cmd) - cmd - (string->symbol cmd)) - - ;;=============================================== - ;; READ/WRITE QUERIES - ;;=============================================== - - ;; SERVERS - ((start-server) (apply server:kind-run params)) - ((kill-server) (set! *server-run* #f)) - - ;; TESTS - ((test-set-state-status-by-id) (apply db:test-set-state-status-by-id dbstruct params)) - ((delete-test-records) (apply db:delete-test-records dbstruct params)) - ((delete-old-deleted-test-records) (apply db:delete-old-deleted-test-records dbstruct params)) - ((test-set-status-state) (apply db:test-set-status-state dbstruct params)) - ((test-set-top-process-pid) (apply db:test-set-top-process-pid dbstruct params)) - ((roll-up-pass-fail-counts) (apply db:roll-up-pass-fail-counts dbstruct params)) - ;; ((update-pass-fail-counts) (apply db:general-call dbstruct 'update-pass-fail-counts params)) - ((top-test-set-per-pf-counts) (apply db:top-test-set-per-pf-counts dbstruct params)) - ((test-set-archive-block-id) (apply db:test-set-archive-block-id dbstruct params)) - - ;; RUNS - ((register-run) (apply db:register-run dbstruct params)) - ((set-tests-state-status) (apply db:set-tests-state-status dbstruct params)) - ((delete-run) (apply db:delete-run dbstruct params)) - ((lock/unlock-run) (apply db:lock/unlock-run dbstruct params)) - ((update-run-event_time) (apply db:update-run-event_time dbstruct params)) - ((update-run-stats) (apply db:update-run-stats dbstruct params)) - ((set-var) (apply db:set-var dbstruct params)) - - ;; STEPS - ((teststep-set-status!) (apply db:teststep-set-status! dbstruct params)) - - ;; TEST DATA - ((test-data-rollup) (apply db:test-data-rollup dbstruct params)) - ((csv->test-data) (apply db:csv->test-data dbstruct params)) - - ;; MISC - ((sync-inmem->db) (let ((run-id (car params))) - (db:sync-touched dbstruct run-id force-sync: #t))) - ((mark-incomplete) (apply db:find-and-mark-incomplete dbstruct params)) - - ;; TESTMETA - ((testmeta-add-record) (apply db:testmeta-add-record dbstruct params)) - ((testmeta-update-field) (apply db:testmeta-update-field dbstruct params)) - - ;; TASKS - ((tasks-add) (apply tasks:add dbstruct params)) - ((tasks-set-state-given-param-key) (apply tasks:set-state-given-param-key dbstruct params)) - ((tasks-get-last) (apply tasks:get-last dbstruct params)) - - ;; ARCHIVES - ;; ((archive-get-allocations) - ((archive-register-disk) (apply db:archive-register-disk dbstruct params)) - ((archive-register-block-name)(apply db:archive-register-block-name dbstruct params)) - ((archive-allocate-testsuite/area-to-block)(apply db:archive-allocate-testsuite/area-to-block dbstruct block-id testsuite-name areakey)) - - ;;====================================================================== - ;; READ ONLY QUERIES - ;;====================================================================== - - ;; KEYS - ((get-key-val-pairs) (apply db:get-key-val-pairs dbstruct params)) - ((get-keys) (db:get-keys dbstruct)) - ((get-key-vals) (apply db:get-key-vals dbstruct params)) - ((get-target) (apply db:get-target dbstruct params)) - ((get-targets) (db:get-targets dbstruct)) - - ;; ARCHIVES - ((test-get-archive-block-info) (apply db:test-get-archive-block-info dbstruct params)) - - ;; TESTS - ((test-toplevel-num-items) (apply db:test-toplevel-num-items dbstruct params)) - ((get-test-info-by-id) (apply db:get-test-info-by-id dbstruct params)) - ((test-get-rundir-from-test-id) (apply db:test-get-rundir-from-test-id dbstruct params)) - ((get-count-tests-running-for-testname) (apply db:get-count-tests-running-for-testname dbstruct params)) - ((get-count-tests-running) (apply db:get-count-tests-running dbstruct params)) - ((get-count-tests-running-in-jobgroup) (apply db:get-count-tests-running-in-jobgroup dbstruct params)) - ;; ((delete-test-step-records) (apply db:delete-test-step-records dbstruct params)) - ((get-previous-test-run-record) (apply db:get-previous-test-run-record dbstruct params)) - ((get-matching-previous-test-run-records)(apply db:get-matching-previous-test-run-records dbstruct params)) - ((test-get-logfile-info) (apply db:test-get-logfile-info dbstruct params)) - ((test-get-records-for-index-file) (apply db:test-get-records-for-index-file dbstruct params)) - ((get-testinfo-state-status) (apply db:get-testinfo-state-status dbstruct params)) - ((test-get-top-process-pid) (apply db:test-get-top-process-pid dbstruct params)) - ((test-get-paths-matching-keynames-target-new) (apply db:test-get-paths-matching-keynames-target-new dbstruct params)) - ((get-prereqs-not-met) (apply db:get-prereqs-not-met dbstruct params)) - ((get-count-tests-running-for-run-id) (apply db:get-count-tests-running-for-run-id dbstruct params)) - ((synchash-get) (apply synchash:server-get dbstruct params)) - ((get-raw-run-stats) (apply db:get-raw-run-stats dbstruct params)) - - ;; RUNS - ((get-run-info) (apply db:get-run-info dbstruct params)) - ((get-run-status) (apply db:get-run-status dbstruct params)) - ((set-run-status) (apply db:set-run-status dbstruct params)) - ((get-tests-for-run) (apply db:get-tests-for-run dbstruct params)) - ((get-test-id) (apply db:get-test-id dbstruct params)) - ((get-tests-for-run-mindata) (apply db:get-tests-for-run-mindata dbstruct params)) - ((get-runs) (apply db:get-runs dbstruct params)) - ((get-num-runs) (apply db:get-num-runs dbstruct params)) - ((get-all-run-ids) (db:get-all-run-ids dbstruct)) - ((get-prev-run-ids) (apply db:get-prev-run-ids dbstruct params)) - ((get-run-ids-matching-target) (apply db:get-run-ids-matching-target dbstruct params)) - ((get-runs-by-patt) (apply db:get-runs-by-patt dbstruct params)) - ((get-run-name-from-id) (apply db:get-run-name-from-id dbstruct params)) - ((get-main-run-stats) (apply db:get-main-run-stats dbstruct params)) - ((get-var) (apply db:get-var dbstruct params)) - ((get-run-stats) (apply db:get-run-stats dbstruct params)) - - ;; STEPS - ((get-steps-data) (apply db:get-steps-data dbstruct params)) - ((get-steps-for-test) (apply db:get-steps-for-test dbstruct params)) - - ;; TEST DATA - ((read-test-data) (apply db:read-test-data dbstruct params)) - - ;; MISC - ((have-incompletes?) (apply db:have-incompletes? dbstruct params)) - ((login) (apply db:login dbstruct params)) - ((general-call) (let ((stmtname (car params)) - (run-id (cadr params)) - (realparams (cddr params))) - (db:with-db dbstruct run-id #t ;; these are all for modifying the db - (lambda (db) - (db:general-call db stmtname realparams))))) - ((sdb-qry) (apply sdb:qry params)) - ((ping) (current-process-id)) - - ;; TESTMETA - ((testmeta-get-record) (apply db:testmeta-get-record dbstruct params)) - - ;; TASKS - ((find-task-queue-records) (apply tasks:find-task-queue-records dbstruct params)))))))) - + (cond + ((not (vector? dat)) ;; it is an error to not receive a vector + (vector #f (vector #f "remote must be called with a vector"))) + ((> *api-process-request-count* 20) ;; 20) + (debug:print 0 *default-log-port* "WARNING: api:execute-requests received an overloaded message.") + (set! *server-overloaded* #t) + (vector #f (vector #f 'overloaded))) ;; the inner vector is what gets returned. nope, don't know why. please refactor! + (else + (let* ((cmd-in (common:safe-vector-ref dat 0 'nocmd)) + (cmd (if (symbol? cmd-in) + cmd-in + (string->symbol cmd-in))) + (params (common:safe-vector-ref dat 1 '())) + (start-t (current-milliseconds)) + (readonly-mode (dbr:dbstruct-read-only dbstruct)) + (readonly-command (member cmd api:read-only-queries)) + (writecmd-in-readonly-mode (and readonly-mode (not readonly-command))) + (foo (begin + #;(common:telemetry-log (conc "api-in:"(->string cmd)) + payload: `((params . ,params))) + + #t)) + (res + (if writecmd-in-readonly-mode + (conc "attempt to run write command "cmd" on a read-only database") + (case cmd + ;;=============================================== + ;; READ/WRITE QUERIES + ;;=============================================== + + ((nocmd) '(#f "All broken!")) + + ((get-keys-write) (db:get-keys dbstruct)) ;; force a dummy "write" query to force server; for debug in -repl + + ;; SERVERS + ((start-server) (apply server:kind-run params)) + ((kill-server) (set! *server-run* #f)) + + ;; TESTS + + ;;((test-set-state-status-by-id) (apply mt:test-set-state-status-by-id dbstruct params)) + ;;BB - commented out above because it was calling below, eventually, incorrectly (dbstruct passed to mt:test-set-state-status-by-id, which previosly did more, but now only passes thru to db:set-state-status-and-roll-up-items. + ((test-set-state-status-by-id) + + ;; (define (db:set-state-status-and-roll-up-items dbstruct run-id test-name item-path state status comment) + (db:set-state-status-and-roll-up-items + dbstruct + (list-ref params 0) ; run-id + (list-ref params 1) ; test-name + #f ; item-path + (list-ref params 2) ; state + (list-ref params 3) ; status + (list-ref params 4) ; comment + )) + + ((delete-test-records) (apply db:delete-test-records dbstruct params)) + ((delete-old-deleted-test-records) (apply db:delete-old-deleted-test-records dbstruct params)) + ((test-set-state-status) (apply db:test-set-state-status dbstruct params)) + ((test-set-top-process-pid) (apply db:test-set-top-process-pid dbstruct params)) + ((set-state-status-and-roll-up-items) (apply db:set-state-status-and-roll-up-items dbstruct params)) + ((set-state-status-and-roll-up-run) (apply db:set-state-status-and-roll-up-run dbstruct params)) + ((top-test-set-per-pf-counts) (apply db:top-test-set-per-pf-counts dbstruct params)) + ((test-set-archive-block-id) (apply db:test-set-archive-block-id dbstruct params)) + + ;; RUNS + ((register-run) (apply db:register-run dbstruct params)) + ((set-tests-state-status) (apply db:set-tests-state-status dbstruct params)) + ((delete-run) (apply db:delete-run dbstruct params)) + ((lock/unlock-run) (apply db:lock/unlock-run dbstruct params)) + ((update-run-event_time) (apply db:update-run-event_time dbstruct params)) + ((update-run-stats) (apply db:update-run-stats dbstruct params)) + ((set-var) (apply db:set-var dbstruct params)) + ((inc-var) (apply db:inc-var dbstruct params)) + ((dec-var) (apply db:dec-var dbstruct params)) + ((del-var) (apply db:del-var dbstruct params)) + ((add-var) (apply db:add-var dbstruct params)) + + ;; STEPS + ((teststep-set-status!) (apply db:teststep-set-status! dbstruct params)) + ((delete-steps-for-test!) (apply db:delete-steps-for-test! dbstruct params)) + + ;; TEST DATA + ((test-data-rollup) (apply db:test-data-rollup dbstruct params)) + ((csv->test-data) (apply db:csv->test-data dbstruct params)) + + ;; MISC + ((sync-inmem->db) (let ((run-id (car params))) + (db:sync-touched dbstruct run-id force-sync: #t))) + ((mark-incomplete) (apply db:find-and-mark-incomplete dbstruct params)) + ((create-all-triggers) (db:create-all-triggers dbstruct)) + ((drop-all-triggers) (db:drop-all-triggers dbstruct)) + + ;; TESTMETA + ((testmeta-add-record) (apply db:testmeta-add-record dbstruct params)) + ((testmeta-update-field) (apply db:testmeta-update-field dbstruct params)) + ((get-tests-tags) (db:get-tests-tags dbstruct)) + + ;; TASKS + ((tasks-add) (apply tasks:add dbstruct params)) + ((tasks-set-state-given-param-key) (apply tasks:set-state-given-param-key dbstruct params)) + ((tasks-get-last) (apply tasks:get-last dbstruct params)) + + ;; NO SYNC DB + ((no-sync-set) (apply db:no-sync-set *no-sync-db* params)) + ((no-sync-get/default) (apply db:no-sync-get/default *no-sync-db* params)) + ((no-sync-del!) (apply db:no-sync-del! *no-sync-db* params)) + ((no-sync-get-lock) (apply db:no-sync-get-lock *no-sync-db* params)) + ((no-sync-add-job) (apply db:no-sync-add-job *no-sync-db* params)) + ((no-sync-take-job) (apply db:no-sync-take-job *no-sync-db* params)) + ((no-sync-job-records-clean) (apply db:no-sync-job-records-clean *no-sync-db* params)) + + ;; ARCHIVES + ;; ((archive-get-allocations) + ((archive-register-disk) (apply db:archive-register-disk dbstruct params)) + ((archive-register-block-name)(apply db:archive-register-block-name dbstruct params)) + ;; ((archive-allocate-testsuite/area-to-block)(apply db:archive-allocate-testsuite/area-to-block dbstruct block-id testsuite-name areakey)) + + ;;====================================================================== + ;; READ ONLY QUERIES + ;;====================================================================== + + ;; KEYS + ((get-key-val-pairs) (apply db:get-key-val-pairs dbstruct params)) + ((get-keys) (db:get-keys dbstruct)) + ((get-key-vals) (apply db:get-key-vals dbstruct params)) + ((get-target) (apply db:get-target dbstruct params)) + ((get-targets) (db:get-targets dbstruct)) + + ;; ARCHIVES + ((test-get-archive-block-info) (apply db:test-get-archive-block-info dbstruct params)) + + ;; TESTS + ((test-toplevel-num-items) (apply db:test-toplevel-num-items dbstruct params)) + ((get-test-info-by-id) (apply db:get-test-info-by-id dbstruct params)) + ((test-get-rundir-from-test-id) (apply db:test-get-rundir-from-test-id dbstruct params)) + ((get-count-tests-running-for-testname) (apply db:get-count-tests-running-for-testname dbstruct params)) + ((get-count-tests-running) (apply db:get-count-tests-running dbstruct params)) + ((get-count-tests-running-in-jobgroup) (apply db:get-count-tests-running-in-jobgroup dbstruct params)) + ;; ((delete-test-step-records) (apply db:delete-test-step-records dbstruct params)) + ;; ((get-previous-test-run-record) (apply db:get-previous-test-run-record dbstruct params)) + ((get-matching-previous-test-run-records)(apply db:get-matching-previous-test-run-records dbstruct params)) + ((test-get-logfile-info) (apply db:test-get-logfile-info dbstruct params)) + ((test-get-records-for-index-file) (apply db:test-get-records-for-index-file dbstruct params)) + ((get-testinfo-state-status) (apply db:get-testinfo-state-status dbstruct params)) + ((test-get-top-process-pid) (apply db:test-get-top-process-pid dbstruct params)) + ((test-get-paths-matching-keynames-target-new) (apply db:test-get-paths-matching-keynames-target-new dbstruct params)) + ((get-prereqs-not-met) (apply db:get-prereqs-not-met dbstruct params)) + ((get-count-tests-running-for-run-id) (apply db:get-count-tests-running-for-run-id dbstruct params)) + ((get-not-completed-cnt) (apply db:get-not-completed-cnt dbstruct params)) + ;; ((synchash-get) (apply synchash:server-get dbstruct params)) + ((get-raw-run-stats) (apply db:get-raw-run-stats dbstruct params)) + ((get-test-times) (apply db:get-test-times dbstruct params)) + + ;; RUNS + ((get-run-info) (apply db:get-run-info dbstruct params)) + ((get-run-status) (apply db:get-run-status dbstruct params)) + ((get-run-state) (apply db:get-run-state dbstruct params)) + ((set-run-status) (apply db:set-run-status dbstruct params)) + ((set-run-state-status) (apply db:set-run-state-status dbstruct params)) + ((update-tesdata-on-repilcate-db) (apply db:update-tesdata-on-repilcate-db dbstruct params)) + ((get-tests-for-run) (apply db:get-tests-for-run dbstruct params)) + ((get-tests-for-run-state-status) (apply db:get-tests-for-run-state-status dbstruct params)) + ((get-test-id) (apply db:get-test-id dbstruct params)) + ((get-tests-for-run-mindata) (apply db:get-tests-for-run-mindata dbstruct params)) + ;; ((get-tests-for-runs-mindata) (apply db:get-tests-for-runs-mindata dbstruct params)) + ((get-runs) (apply db:get-runs dbstruct params)) + ((simple-get-runs) (apply db:simple-get-runs dbstruct params)) + ((get-num-runs) (apply db:get-num-runs dbstruct params)) + ((get-runs-cnt-by-patt) (apply db:get-runs-cnt-by-patt dbstruct params)) + ((get-all-run-ids) (db:get-all-run-ids dbstruct)) + ((get-prev-run-ids) (apply db:get-prev-run-ids dbstruct params)) + ((get-run-ids-matching-target) (apply db:get-run-ids-matching-target dbstruct params)) + ((get-runs-by-patt) (apply db:get-runs-by-patt dbstruct params)) + ((get-run-name-from-id) (apply db:get-run-name-from-id dbstruct params)) + ((get-main-run-stats) (apply db:get-main-run-stats dbstruct params)) + ((get-var) (apply db:get-var dbstruct params)) + ((get-run-stats) (apply db:get-run-stats dbstruct params)) + ((get-run-times) (apply db:get-run-times dbstruct params)) + + ;; STEPS + ((get-steps-data) (apply db:get-steps-data dbstruct params)) + ((get-steps-for-test) (apply db:get-steps-for-test dbstruct params)) + ((get-steps-info-by-id) (apply db:get-steps-info-by-id dbstruct params)) + + ;; TEST DATA + ((read-test-data) (apply db:read-test-data dbstruct params)) + ((read-test-data*) (apply db:read-test-data* dbstruct params)) + ((get-data-info-by-id) (apply db:get-data-info-by-id dbstruct params)) + + ;; MISC + ((get-latest-host-load) (apply db:get-latest-host-load dbstruct params)) + ((have-incompletes?) (apply db:have-incompletes? dbstruct params)) + ((login) (apply db:login dbstruct params)) + ((general-call) (let ((stmtname (car params)) + (run-id (cadr params)) + (realparams (cddr params))) + (db:general-call dbstruct stmtname realparams))) + ((sdb-qry) (apply sdb:qry params)) + ((ping) (current-process-id)) + ((get-changed-record-ids) (apply db:get-changed-record-ids dbstruct params)) + ((get-run-record-ids) (apply db:get-run-record-ids dbstruct params)) + ;; TESTMETA + ((testmeta-get-record) (apply db:testmeta-get-record dbstruct params)) + + ;; TASKS + ((find-task-queue-records) (apply tasks:find-task-queue-records dbstruct params)) + (else + (debug:print 0 *default-log-port* "ERROR: bad api call " cmd) + (conc "ERROR: BAD api call " cmd)))))) + + + ;; save all stats + (let ((delta-t (- (current-milliseconds) + start-t))) + (hash-table-set! *db-api-call-time* cmd + (cons delta-t (hash-table-ref/default *db-api-call-time* cmd '())))) + (if writecmd-in-readonly-mode + (begin + #;(common:telemetry-log (conc "api-out:"(->string cmd)) + payload: `((params . ,params) + (ok-res . #t))) + (vector #f res)) + (begin + #;(common:telemetry-log (conc "api-out:"(->string cmd)) + payload: `((params . ,params) + (ok-res . #f))) + (vector #t res)))))))) ;; http-server send-response ;; api:process-request ;; db:* ;; ;; NB// Runs on the server as part of the server loop ;; (define (api:process-request dbstruct $) ;; the $ is the request vars proc + (set! *api-process-request-count* (+ *api-process-request-count* 1)) (let* ((cmd ($ 'cmd)) (paramsj ($ 'params)) - (params (db:string->obj paramsj transport: 'http)) ;; (rmt:json-str->dat paramsj)) - (resdat (api:execute-requests dbstruct (vector cmd params))) ;; #( flag result ) - (res (vector-ref resdat 1))) - + (params (db:string->obj paramsj transport: 'http)) ;; incoming data from the POST (or is it a GET?) + (resdat (api:execute-requests dbstruct (vector cmd params))) ;; process the request, resdat = #( flag result ) + (success (common:safe-vector-ref resdat 0 #f)) + (res (common:safe-vector-ref resdat 1 #f))) ;; (vector flag payload), get the payload, ignore the flag (why?) + (if (not success) + (debug:print 0 *default-log-port* "ERROR: success flag is #f for " cmd " with params " params)) + (if (> *api-process-request-count* *max-api-process-requests*) + (set! *max-api-process-requests* *api-process-request-count*)) + (set! *api-process-request-count* (- *api-process-request-count* 1)) ;; This can be here but needs controls to ensure it doesn't run more than every 4 seconds ;; (rmt:dat->json-str ;; (if (or (string? res) ;; (list? res) ;; (number? res) ADDED apimod.scm Index: apimod.scm ================================================================== --- /dev/null +++ apimod.scm @@ -0,0 +1,37 @@ +;;====================================================================== +;; Copyright 2017, Matthew Welland. +;; +;; This file is part of Megatest. +;; +;; Megatest is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. +;; +;; Megatest is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with Megatest. If not, see . + +;;====================================================================== + +(declare (unit apimod)) +(declare (uses commonmod)) +(declare (uses ulex)) + +(module apimod + * + +(import scheme chicken data-structures extras) +(import (prefix sqlite3 sqlite3:) posix typed-records srfi-18) +(import commonmod) +(import (prefix ulex ulex:)) + + +(define (api:execute-requests params) + #f) + +) Index: archive.scm ================================================================== --- archive.scm +++ archive.scm @@ -1,18 +1,26 @@ ;; Copyright 2006-2014, Matthew Welland. ;; -;; This program is made available under the GNU GPL version 2.0 or -;; greater. See the accompanying file COPYING for details. +;; This file is part of Megatest. +;; +;; Megatest is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. +;; +;; Megatest is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. ;; -;; This program is distributed WITHOUT ANY WARRANTY; without even the -;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR -;; PURPOSE. +;; You should have received a copy of the GNU General Public License +;; along with Megatest. If not, see . +;; ;; strftime('%m/%d/%Y %H:%M:%S','now','localtime') -(use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking format md5 message-digest srfi-18) -(import (prefix sqlite3 sqlite3:)) +(use (prefix sqlite3 sqlite3:) srfi-1 posix regex regex-case srfi-69 format md5 message-digest srfi-18) (declare (unit archive)) (declare (uses db)) (declare (uses common)) @@ -30,11 +38,11 @@ (flavor 'plain) ;; type of machine to run jobs on (maxload 1.5) ;; max allowed load for this work (adisks (archive:get-archive-disks))) ;; get testdir size ;; - hand off du to job mgr - (if (and (file-exists? testdir) + (if (and (common:file-exists? testdir) (file-is-writable? testdir)) (let* ((dused (jobrunner:run-job flavor ;; machine type maxload ;; max allowed load '() ;; prevars - environment vars to set for the job @@ -72,29 +80,52 @@ (or (common:get-disk-with-most-free-space candidate-disks dused) (archive:allocate-new-archive-block #f #f #f)))) ;; BROKEN. testname itempath)))) ;; allocate a new archive area ;; -(define (archive:allocate-new-archive-block run-area-home testsuite-name dneeded) - (let* ((adisks (archive:get-archive-disks)) - (best-disk (common:get-disk-with-most-free-space adisks dneeded))) - (if best-disk - (let* ((bdisk-name (car best-disk)) - (bdisk-path (cdr best-disk)) - (area-key (substring (message-digest-string (md5-primitive) run-area-home) 0 5)) - (bdisk-id (rmt:archive-register-disk bdisk-name bdisk-path (get-df bdisk-path))) - (archive-name (let ((sec (current-seconds))) - (conc (time->string (seconds->local-time sec) "%Y") - "_q" (seconds->quarter sec) "/" - testsuite-name "_" area-key))) - (archive-path (conc bdisk-path "/" archive-name)) - (block-id (rmt:archive-register-block-name bdisk-id archive-path))) - ;; (allocation-id (rmt:archive-allocate-testsuite/area-to-block block-id testsuite-name area-key))) - (if block-id ;; (and block-id allocation-id) - (cons block-id archive-path) - #f)) - #f))) +(define (archive:allocate-new-archive-block blockid-cache run-area-home testsuite-name dneeded target run-name test-name) + (let ((key (conc testsuite-name "/" target "/" run-name "/" test-name))) + (if (hash-table-exists? blockid-cache key) + (hash-table-ref blockid-cache key) + (let* ((pscript (configf:lookup *configdat* "archive" "pathscript")) + (pscript-cmd (conc pscript " " testsuite-name " " target " " run-name " " test-name)) + (apath (if pscript + (handle-exceptions + exn + (begin + (debug:print 0 *default-log-port* "ERROR: script \"" pscript-cmd "\" failed to run properly. exn=" exn) + (exit 1)) + (with-input-from-pipe + pscript-cmd + read-line)) + #f)) ;; this is the user-calculated archive path + (adisks (archive:get-archive-disks)) + (best-disk (common:get-disk-with-most-free-space adisks dneeded))) + (if best-disk + (let* ((bdisk-name (car best-disk)) + (bdisk-path (cdr best-disk)) + (area-key (substring (message-digest-string (md5-primitive) run-area-home) 0 5)) + (bdisk-id (rmt:archive-register-disk bdisk-name bdisk-path (get-df bdisk-path))) + (archive-name (if apath + apath + (let ((sec (current-seconds))) + (conc (time->string (seconds->local-time sec) "%Y") + "_q" (seconds->quarter sec) "/" + testsuite-name "_" area-key)))) + (archive-path (conc bdisk-path "/" archive-name)) + (block-id (rmt:archive-register-block-name bdisk-id archive-path))) + ;; (allocation-id (rmt:archive-allocate-testsuite/area-to-block block-id testsuite-name area-key))) + (if block-id ;; (and block-id allocation-id) + (let ((res (cons block-id archive-path))) + (hash-table-set! blockid-cache key res) + res) + (begin + (debug:print 0 *default-log-port* "WARNING: no disk found for " target ", " run-name ", " test-name ", archive-path=" archive-path) + #f))) + (begin + (debug:print 0 *default-log-port* "WARNING: no disk found for " target ", " run-name ", " test-name ) + #f)))))) ;; no best disk found ;; archive - run bup ;; ;; 1. create the bup dir if not exists ;; 2. start the du of each directory @@ -103,119 +134,340 @@ ;; (define (archive:run-bup archive-command run-id run-name tests rp-mutex bup-mutex) ;; move the getting of archive space down into the below block so that a single run can ;; allocate as needed should a disk fill up ;; - (let* ((min-space (string->number (or (configf:lookup *configdat* "archive" "minspace") "1000"))) - (archive-info (archive:allocate-new-archive-block *toppath* (common:get-testsuite-name) min-space)) - (archive-dir (if archive-info (cdr archive-info) #f)) - (archive-id (if archive-info (car archive-info) -1)) - (disk-groups (make-hash-table)) - (test-groups (make-hash-table)) ;; these two (disk and test groups) could be combined nicely - (bup-exe (or (configf:lookup *configdat* "archive" "bup") "bup")) - (compress (or (configf:lookup *configdat* "archive" "compress") "9")) - (linktree (configf:lookup *configdat* "setup" "linktree"))) - - (if (not archive-dir) ;; no archive disk found, this is fatal - (begin - (debug:print 0 *default-log-port* "FATAL: No archive disks found. Please add disks with at least " min-space " MB space to the [archive-disks] section of megatest.config") - (debug:print 0 *default-log-port* " use [archive] minspace to specify minimum available space") - (debug:print 0 *default-log-port* " disks: " (string-intersperse (map cadr (archive:get-archive-disks)) "\n ")) - (exit 1)) - (debug:print-info 0 *default-log-port* "Using path " archive-dir " for archiving")) - + (let* ((blockid-cache (make-hash-table)) + (tsname (common:get-testsuite-name)) + (target (string-intersperse (map cadr (rmt:get-key-val-pairs run-id)) "/")) + (min-space (string->number (or (configf:lookup *configdat* "archive" "minspace") "1000"))) + (arch-groups (make-hash-table)) ;; archive groups, each corrosponds to a bup area + (disk-groups (make-hash-table)) ;; + (test-groups (make-hash-table)) ;; these two (disk and test groups) could be combined nicely + (test-dirs (make-hash-table)) + (bup-exe (or (configf:lookup *configdat* "archive" "bup") "bup")) + (compress (or (configf:lookup *configdat* "archive" "compress") "9")) + (linktree (common:get-linktree)) ;; (configf:lookup *configdat* "setup" "linktree"))) + (archiver (let ((s (configf:lookup *configdat* "archive" "archiver"))) + (if s (string->symbol s) 'bup))) + (archiver-cmd (case archiver + ((tar) "tar cfj ARCHIVE_NAME.tar.bz2 ") + ((7z) " 7z u -t7z -m0=lzma -mx=9 -mfb=64 -md=32m -ms=on ARCHIVE_NAME.7z ") + (else #f))) + (src-archive-linktree (rmt:get-var "src-archive-linktree")) + (print-prefix "Running: ") ;; change to #f to turn off printing + (preclean-spec (configf:get-section *configdat* "archive-preclean"))) + + (if (or (not src-archive-linktree) (not (equal? src-archive-linktree linktree))) + (rmt:set-var "src-archive-linktree" linktree)) + ;; (tests:match patt testname itempath) + ;; from the test info bin the path to the test by stem ;; (for-each (lambda (test-dat) (let* ((item-path (db:test-get-item-path test-dat)) (test-name (db:test-get-testname test-dat)) (test-id (db:test-get-id test-dat)) (run-id (db:test-get-run_id test-dat)) - (target (string-intersperse (map cadr (rmt:get-key-val-pairs run-id)) "/")) - + (toplevel/children (and (db:test-get-is-toplevel test-dat) (> (rmt:test-toplevel-num-items run-id test-name) 0))) (test-partial-path (conc target "/" run-name "/" (db:test-make-full-name test-name item-path))) ;; note the trailing slash to get the dir inspite of it being a link (test-path (conc linktree "/" test-partial-path)) (mutex-lock! rp-mutex) - (test-physical-path (if (file-exists? test-path) + (test-physical-path (if (common:file-exists? test-path) (common:real-path test-path) #f)) (mutex-unlock! rp-mutex) (partial-path-index (if test-physical-path (substring-index test-partial-path test-physical-path) #f)) (test-base (if (and partial-path-index test-physical-path ) (substring test-physical-path 0 partial-path-index) - #f))) - - (cond - (toplevel/children - (debug:print 0 *default-log-port* "WARNING: cannot archive " test-name " with id " test-id " as it is a toplevel test with children")) - ((not (file-exists? test-path)) - (debug:print 0 *default-log-port* "WARNING: Cannot archive " test-name "/" item-path " as path " test-path " does not exist")) - (else - (debug:print 0 *default-log-port* + #f)) + ;; we need our archive dir checked for every test to enable folks who want to store other ways. + (archive-info (archive:allocate-new-archive-block blockid-cache *toppath* tsname min-space target run-name test-name)) + (archive-dir (if archive-info (cdr archive-info) #f)) + (archive-id (if archive-info (car archive-info) -1))) + + (if (not archive-dir) ;; no archive disk found, this is fatal + (begin + (debug:print 0 *default-log-port* "FATAL: No archive disks found. Please add disks with at least " + min-space " MB space to the [archive-disks] section of megatest.config") + (debug:print 0 *default-log-port* " use [archive] minspace to specify minimum available space") + (debug:print 0 *default-log-port* " disks: " + (string-intersperse (map cadr (archive:get-archive-disks)) "\n ")) + (exit 1)) + (debug:print-info 0 *default-log-port* "Using path " archive-dir " for archiving test " test-path)) + + ;; preclean the test directory per the spec if provided + (if (not (null? preclean-spec)) ;; we've been asked to preclean before archiving + (let loop ((spec (car preclean-spec)) + (tail (cdr preclean-spec))) + (if (> (length spec) 1) + (let ((testspec (car spec)) + (rules (cadr spec))) + (if (tests:match testspec test-name item-path) + (begin + (debug:print 0 *default-log-port* "INFO: cleanup requested for " test-physical-path) + (common:dir-clean-up test-physical-path rules remove-empty: #t)) + (if (not (null? tail)) + (loop (car tail)(cdr tail))))) + (begin + (debug:print 0 *default-log-port* "ERROR: bad spec line in [archive-preclean] section. \"" spec "\"") + (if (not (null? tail))(loop (car tail)(cdr tail))))))) + (cond + (toplevel/children + (debug:print 0 *default-log-port* "WARNING: cannot archive " test-name " with id " test-id + " as it is a toplevel test with children")) + ((not (common:file-exists? test-path)) + (debug:print 0 *default-log-port* "WARNING: Cannot archive " test-name "/" item-path + " as path " test-path " does not exist")) + (else + (debug:print 2 *default-log-port* "From test-dat=" test-dat " derived the following:\n" "test-partial-path = " test-partial-path "\n" "test-path = " test-path "\n" "test-physical-path = " test-physical-path "\n" "partial-path-index = " partial-path-index "\n" "test-base = " test-base) - (hash-table-set! disk-groups test-base (cons test-physical-path (hash-table-ref/default disk-groups test-base '()))) - (hash-table-set! test-groups test-base (cons test-dat (hash-table-ref/default test-groups test-base '()))) - test-path)))) - tests) - ;; for each disk-group - (for-each - (lambda (disk-group) - (debug:print 0 *default-log-port* "Processing disk-group " disk-group) - (let* ((test-paths (hash-table-ref disk-groups disk-group)) - ;; ((string-intersperse (map cadr (rmt:get-key-val-pairs 1)) "-") - (bup-init-params (list "-d" archive-dir "init")) - (bup-index-params (append (list "-d" archive-dir "index") test-paths)) - (bup-save-params (append (list "-d" archive-dir "save" ;; (conc "--strip-path=" linktree) - (conc "-" compress) ;; or (conc "--compress=" compress) - "-n" (conc (common:get-testsuite-name) "-" run-id) - (conc "--strip-path=" disk-group)) - test-paths)) - (print-prefix #f)) ;; "Running: ")) ;; change to #f to turn off printing - (if (not (file-exists? archive-dir)) - (create-directory archive-dir #t)) - (if (not (file-exists? (conc archive-dir "/HEAD"))) - (begin - ;; replace this with jobrunner stuff enventually - (debug:print-info 0 *default-log-port* "Init bup in " archive-dir) - ;; (mutex-lock! bup-mutex) - (run-n-wait bup-exe params: bup-init-params print-cmd: print-prefix) - ;; (mutex-unlock! bup-mutex) - )) - (debug:print-info 0 *default-log-port* "Indexing data to be archived") - ;; (mutex-lock! bup-mutex) - (run-n-wait bup-exe params: bup-index-params print-cmd: print-prefix) - (debug:print-info 0 *default-log-port* "Archiving data with bup") - (run-n-wait bup-exe params: bup-save-params print-cmd: print-prefix) - ;; (mutex-unlock! bup-mutex) - (for-each - (lambda (test-dat) - (let ((test-id (db:test-get-id test-dat)) - (run-id (db:test-get-run_id test-dat))) - (rmt:test-set-archive-block-id run-id test-id archive-id) - (if (member archive-command '("save-remove")) - (runs:remove-test-directory test-dat 'archive-remove)))) - (hash-table-ref test-groups disk-group)))) - (hash-table-keys disk-groups)) - #t)) + (hash-table-set! disk-groups test-base + (cons test-physical-path (hash-table-ref/default disk-groups test-base '()))) + (hash-table-set! test-groups test-base + (cons test-dat (hash-table-ref/default test-groups test-base '()))) + (hash-table-set! arch-groups test-base + (cons archive-info (hash-table-ref/default arch-groups test-base '()))) + (hash-table-set! test-dirs test-id test-path))))) + ;; test-path)))) + tests) + (debug:print 0 *default-log-port* "INFO: DISK GROUPS=" (hash-table->alist disk-groups)) + ;; for each disk-group, initialize the bup area if needed + (for-each + (lambda (test-base) + (let* ((disk-group (hash-table-ref disk-groups test-base)) + (arch-group (hash-table-ref arch-groups test-base)) + (arch-info (car arch-group)) ;; don't know yet how this will work, can I get more than one possibility? + (archive-id (car arch-info)) + (archive-dir (cdr arch-info))) + (debug:print 0 *default-log-port* "Processing disk-group " test-base) + (let* ((test-paths-in (hash-table-ref disk-groups test-base)) + (test-paths (if (args:get-arg "-include") + (let ((subpaths (string-split (args:get-arg "-include") ","))) + (apply append + (map (lambda (p) + (map (lambda (subp) + (conc p "/" subp)) + subpaths)) + test-paths-in))) + test-paths-in))) + (if (not (common:file-exists? archive-dir)) + (create-directory archive-dir #t)) + (case archiver + ((bup) ;; Archive using bup + (let* ((bup-init-params (list "-d" archive-dir "init")) + (bup-index-params (append (list "-d" archive-dir "index") test-paths)) + (bup-save-params (append (list "-d" archive-dir "save" ;; (conc "--strip-path=" linktree) + (conc "-" compress) ;; or (conc "--compress=" compress) + "-n" (conc (common:get-testsuite-name) "-"(string-substitute "/" "-" target " ")) + (conc "--strip-path=" (conc test-base target "/" )) ;; if we push to the directory do we need this? + ) + test-paths))) + (if (not (common:file-exists? (conc archive-dir "/HEAD"))) + (begin + ;; replace this with jobrunner stuff enventually + (debug:print-info 2 *default-log-port* "Init bup in " archive-dir) + ;; (mutex-lock! bup-mutex) + (let-values (((pid-val exit-status exit-code) (run-n-wait bup-exe params: bup-init-params print-cmd: print-prefix))) + (if (not (eq? exit-code 0)) + (begin + (debug:print-error 0 *default-log-port* "There was an error initializing bup. Archive failed.") + (exit 1)))) + ;; (mutex-unlock! bup-mutex) + )) + (debug:print-info 2 *default-log-port* "Indexing data to be archived") + ;; (mutex-lock! bup-mutex) + (let-values (((pid-val exit-status exit-code) (run-n-wait bup-exe params: bup-index-params print-cmd: print-prefix))) + (if (not (eq? exit-code 0)) + (begin + (debug:print-error 0 *default-log-port* "There was an error Indexing bup. Archive failed.") + (exit 1)))) + (debug:print-info 2 *default-log-port* "Archiving data with bup") + (let-values (((pid-val exit-status exit-code) (run-n-wait bup-exe params: bup-save-params print-cmd: print-prefix))) + (if (not (eq? exit-code 0)) + (begin + (debug:print-error 0 *default-log-port* "There was an archiving data with bup. Archive failed.") + (exit 1)))))) + ((7z tar) + (for-each + (lambda (test-dat) + (let* ((test-id (db:test-get-id test-dat)) + (test-name (db:test-get-testname test-dat)) + (item-path (db:test-get-item-path test-dat)) + (test-full-name (db:test-make-full-name test-name item-path)) + (run-id (db:test-get-run_id test-dat)) + (target (string-intersperse (map cadr (rmt:get-key-val-pairs run-id)) "/")) + (run-name (rmt:get-run-name-from-id run-id)) + (source-dir (hash-table-ref test-dirs test-id)) ;; (conc test-base "/" test-name "/" item-path)) + (target-dir (string-substitute "/$" "" (conc archive-dir "/" target "/" run-name "/" test-full-name)))) + ;; create the test and item-path levels under archive-dir + (create-directory (pathname-directory target-dir) #t) + (run-n-wait + (conc + (string-substitute "ARCHIVE_NAME" target-dir archiver-cmd) " " + "." + ) + print-cmd: print-prefix + run-dir: source-dir))) + (hash-table-ref test-groups test-base)))) + ;; (mutex-unlock! bup-mutex) + (for-each + (lambda (test-dat) + (let ((test-id (db:test-get-id test-dat)) + (run-id (db:test-get-run_id test-dat))) + (rmt:test-set-archive-block-id run-id test-id archive-id) + (if (member (symbol->string archive-command) '("save-remove")) + (begin + (debug:print-info 0 *default-log-port* "remove testdat") + (runs:remove-test-directory test-dat 'archive-remove))))) + (hash-table-ref test-groups test-base))))) + (hash-table-keys disk-groups)) + #t)) + +(define (archive:megatest-db target-patt run-patt) + (let* ((blockid-cache (make-hash-table)) + (tsname (common:get-testsuite-name)) + (min-space (string->number (or (configf:lookup *configdat* "archive" "minspace") "1000"))) + (bup-exe (or (configf:lookup *configdat* "archive" "bup") "bup")) + (compress (or (configf:lookup *configdat* "archive" "compress") "9")) + (archiver (let ((s (configf:lookup *configdat* "archive" "archiver"))) + (if s (string->symbol s) 'bup))) + (rsync-exe (or (configf:lookup *configdat* "archive" "rsync") "rsync")) + (print-prefix "Running: ") + (archive-info (archive:allocate-new-archive-block blockid-cache *toppath* tsname min-space target-patt run-patt "megatest-db")) + (archive-dir (if archive-info (cdr archive-info) #f)) + (archive-id (if archive-info (car archive-info) -1)) + (home-host (common:get-homehost)) + (archive-time (seconds->std-time-str (current-seconds))) + (archive-staging-db (conc *toppath* "/.db-snapshot/archive_" archive-time)) + (tmp-db-path (conc (common:get-db-tmp-area) "/megatest.db")) + (dbfile (conc archive-staging-db "/megatest.db"))) + (create-directory archive-staging-db #t) + (let-values (((pid-val exit-status exit-code) (run-n-wait rsync-exe params: (list "-v" (conc (car home-host) ":"tmp-db-path) archive-staging-db) print-cmd: print-prefix))) + (if (eq? exit-code 0) + (case archiver + ((bup) ;; Archive using bup + (let* ((bup-init-params (list "-d" archive-dir "init")) + (bup-index-params (list "-d" archive-dir "index" archive-staging-db)) + (bup-save-params (list "-d" archive-dir "save" ;; (conc "--strip-path=" linktree) + (conc "-" compress) ;; or (conc "--compress=" compress) + "-n" (conc tsname "-megatest-db" ) + (conc "--strip-path=" archive-staging-db ) ;; if we push to the directory do we need this? + dbfile))) + (if (not (common:file-exists? (conc archive-dir "/HEAD"))) + (begin + ;; replace this with jobrunner stuff enventually + (debug:print-info 2 *default-log-port* "Init bup in " archive-dir) + (let-values (((pid-val exit-status exit-code)(run-n-wait bup-exe params: bup-init-params print-cmd: print-prefix))) + (if (not (eq? exit-code 0)) + (begin + (debug:print-error 0 *default-log-port* "There was an error initializing bup. Archive failed.") + (exit 1)))))) + (debug:print-info 2 *default-log-port* "Indexing data to be archived") + (let-values (((pid-val exit-status exit-code) (run-n-wait bup-exe params: bup-index-params print-cmd: print-prefix))) + (if (not (eq? exit-code 0)) + (begin + (debug:print-error 0 *default-log-port* "There was an error Indexing bup. Archive failed.") + (exit 1)))) + (debug:print-info 2 *default-log-port* "Archiving data with bup") + (let-values (((pid-val exit-status exit-code) (run-n-wait bup-exe params: bup-save-params print-cmd: print-prefix))) + (if (not (eq? exit-code 0)) + (begin + (debug:print-error 0 *default-log-port* "There was an error archiving data with bup. Archive failed.") + (exit 1)) + (debug:print-info 2 *default-log-port* "To restore megatest.db run megatest -archive replicacte-db -source archive-dir -time-stamp . Current timestamp: " (seconds->std-time-str (current-seconds))))))) + (else + (debug:print-info 0 *default-log-port* "No support for databse archiving with " archiver))) + (debug:print-error 0 *default-log-port* "There was an error rsyncing tmp database"))))) + +(define (archive:restore-db archive-path ts) + (let* ((bup-exe (or (configf:lookup *configdat* "archive" "bup") "bup")) + (archive-internal-path (conc (common:get-testsuite-name) "-megatest-db/" ts "/megatest.db" )) + (bup-restore-params (list "-d" archive-path "restore" "-C" *toppath* archive-internal-path))) + (debug:print-info 0 *default-log-port* "Restoring archived data to " *toppath* " from archive in " archive-path " ... " archive-internal-path) + (run-n-wait bup-exe params: bup-restore-params print-cmd: #f)) + (db:multi-db-sync + (db:setup #f) + 'killservers + ;'dejunk + ;'adj-testids + 'old2new + ) + (debug:print-info 1 *default-log-port* "dropping trigerrs to update linktree") + (rmt:drop-all-triggers) + + (let* ((linktree (common:get-linktree)) ;; (configf:lookup *configdat* "setup" "linktree"))) + (src-archive-linktree (rmt:get-var "src-archive-linktree"))) + (if (not (equal? src-archive-linktree linktree)) + (rmt:update-tesdata-on-repilcate-db src-archive-linktree linktree)) + (debug:print-info 1 *default-log-port* "creating triggers after updating linktree") + (rmt:create-all-triggers) +)) + +(define (archive:ls->list bup-exe archive-dir internal-path) + (let ((cmd (conc bup-exe " -d " archive-dir " ls -l " internal-path "| awk '{print $6}' | sort")) + (res '())) + (handle-exceptions + exn + #f ;; anything goes wrong - assume the process in NOT running. + (with-input-from-pipe + cmd + (lambda () + (let* ((inl (read-lines))) + (reverse inl))))))) + +(define (time-string->seconds tstr ds-flag) + (let* ((atime (string->time tstr "%Y-%m-%d-%H%M%S"))) + (vector-set! atime 8 ds-flag) + (local-time->seconds atime))) + +(define (seconds->std-time-str sec) + (time->string + (seconds->local-time sec) + "%Y-%m-%d-%H%M%S")) + + +(define (archive:get-timestamp-dir bup-exe archive-dir testsuite-name target test-partial-path test-last-update) + (print (seconds->std-time-str test-last-update)) + (let* ((internal-path (conc testsuite-name "-" target)) + (ts-list (archive:ls->list bup-exe archive-dir internal-path)) + (ds-flag (vector-ref (seconds->local-time) 8))) + (let loop ((hed (car ts-list)) + (tail (cdr ts-list))) + (if (and (null? tail) (equal? hed "latest")) + #f + (if (and (not (null? tail)) (equal? hed "latest")) + (loop (car tail) (cdr tail)) + (let* ((archive-seconds (time-string->seconds hed ds-flag))) + (if (< (abs (- archive-seconds test-last-update)) 120) + (let* ((test-list (archive:ls->list bup-exe archive-dir (conc internal-path "/" hed "/" test-partial-path)))) + (if (> (length test-list) 0) + hed + (if (not (null? tail)) + (loop (car tail) (cdr tail)) + #f))) + (if (null? tail) + #f + (loop (car tail) (cdr tail)))))))))) (define (archive:bup-restore archive-command run-id run-name tests rp-mutex bup-mutex) ;; move the getting of archive space down into the below block so that a single run can ;; allocate as needed should a disk fill up ;; (let* ((bup-exe (or (configf:lookup *configdat* "archive" "bup") "bup")) - (linktree (configf:lookup *configdat* "setup" "linktree"))) + (linktree (common:get-linktree))) ;; (configf:lookup *configdat* "setup" "linktree"))) ;; from the test info bin the path to the test by stem ;; (for-each (lambda (test-dat) @@ -228,33 +480,39 @@ (keyvals (rmt:get-key-val-pairs run-id)) (target (string-intersperse (map cadr keyvals) "/")) (toplevel/children (and (db:test-get-is-toplevel test-dat) (> (rmt:test-toplevel-num-items run-id test-name) 0))) - (test-partial-path (conc target "/" run-name "/" (db:test-make-full-name test-name item-path))) + (test-partial-path (conc run-name "/" (db:test-make-full-name test-name item-path))) ;; note the trailing slash to get the dir inspite of it being a link (test-path (conc linktree "/" test-partial-path)) ;; if the old path was not deleted then prev-test-physical-path will end up pointing to a real directory (mutex-lock! rp-mutex) - (prev-test-physical-path (if (file-exists? test-path) + (prev-test-physical-path (if (common:file-exists? test-path) ;; (read-symbolic-link test-path #t) (common:real-path test-path) #f)) (mutex-unlock! rp-mutex) (new-test-physical-path (conc best-disk "/" test-partial-path)) (archive-block-id (db:test-get-archived test-dat)) + (test-last-update (db:test-get-last_update test-dat)) (archive-block-info (rmt:test-get-archive-block-info archive-block-id)) (archive-path (if (vector? archive-block-info) (vector-ref archive-block-info 2) ;; look in db.scm for test-get-archive-block-info for the vector record info #f)) ;; no archive found? - (archive-internal-path (conc (common:get-testsuite-name) "-" run-id "/latest/" test-partial-path))) - + (archive-timestamp-dir (if archive-path (archive:get-timestamp-dir bup-exe archive-path (common:get-testsuite-name) (string-substitute "/" "-" target " ") test-partial-path test-last-update) #f)) + (archive-internal-path (conc (common:get-testsuite-name) "-" (string-substitute "/" "-" target " ") "/" archive-timestamp-dir "/" test-partial-path)) + (include-paths (args:get-arg "-include")) + (exclude-pattern (args:get-arg "-exclude-rx")) + (exclude-file (args:get-arg "-exclude-rx-from"))) + (if (not archive-timestamp-dir) + (debug:print-error 0 *default-log-port* "Archive not found for testsuite" (common:get-testsuite-name) " run/test/itempath" test-partial-path) + (begin ;; some sanity checks, move an existing path out of the way - iif it is not a toplevel with children - ;; (if (and (not toplevel/children) ;; special handling needed for toplevel with children prev-test-physical-path - (file-exists? prev-test-physical-path)) ;; what to do? abort or clean up or link it in? + (common:file-exists? prev-test-physical-path)) ;; what to do? abort or clean up or link it in? (let* ((base (pathname-directory prev-test-physical-path)) (dirn (pathname-file prev-test-physical-path)) (newn (conc base "/." dirn))) (debug:print-error 0 *default-log-port* "the old directory " prev-test-physical-path ", still exists! Moving it to " newn) (rename-file prev-test-physical-path newn))) @@ -264,17 +522,14 @@ (begin ;; CREATE WORK AREA ;; test-src-path == #f ==> don't copy in data from tests directory ;; itemdat == string ==> use directly (create-work-area run-id run-name keyvals test-id #f best-disk test-name item-path) ;; #!key (remtries 2)) - ;; 1. Get the block id from the test info ;; 2. Get the block data given the block id ;; 3. Construct the paths etc. for the following command: - ;; ;; bup -d /tmp/matt/adisk1/2015_q1/fullrun_e1a40/ restore -C /tmp/seeme fullrun-30/latest/ubuntu/nfs/none/w02.1.20.54_b/ - ;; DO BUP RESTORE (let* ((new-test-dat (rmt:get-test-info-by-id run-id test-id)) (new-test-path (if (vector? new-test-dat ) (db:test-get-rundir new-test-dat) (begin @@ -281,12 +536,97 @@ (debug:print-error 0 *default-log-port* "unable to get data for run-id=" run-id ", test-id=" test-id) (exit 1)))) ;; new-test-path won't work - must use best-disk instead? Nope, new-test-path but tack on /.. (bup-restore-params (list "-d" archive-path "restore" "-C" (conc new-test-path "/..") archive-internal-path))) (debug:print-info 0 *default-log-port* "Restoring archived data to " new-test-physical-path " from archive in " archive-path " ... " archive-internal-path) + (debug:print-info 0 *default-log-port* bup-exe " " (string-join bup-restore-params " ")) ;; (mutex-lock! bup-mutex) (run-n-wait bup-exe params: bup-restore-params print-cmd: #f) ;; (mutex-unlock! bup-mutex) (mt:test-set-state-status-by-id run-id test-id "COMPLETED" #f #f))) - (debug:print-error 0 *default-log-port* "No archive path in the record for run-id=" run-id " test-id=" test-id)))) + (debug:print-error 0 *default-log-port* "No archive path in the record for run-id=" run-id " test-id=" test-id)))))) (filter vector? tests)))) - + +(define (common:get-youngest-test tests) + (if (null? tests) + #f + (let ((res #f)) + (for-each + (lambda (test-dat) + (let ((event-time (db:test-get-event_time test-dat))) + (if (or (not res) + (> event-time (db:test-get-event_time res))) + (set! res test-dat)))) + tests) + res))) + +;; from an archive get a specific path - works ONLY with bup for now +;; +(define (archive:bup-get-data archive-command run-id-in run-name-in tests rp-mutex bup-mutex) + (if (null? tests) + (debug:print-info 0 *default-log-port* "get-data called with no matching tests to operate on.") + + (let* ((bup-exe (or (configf:lookup *configdat* "archive" "bup") "bup")) + (linktree (common:get-linktree)) ;; (configf:lookup *configdat* "setup" "linktree"))) + ;; (test-dat (common:get-youngest-test tests)) + (destpath (args:get-arg "-dest"))) + (cond + ((null? tests) + (debug:print-error 0 *default-log-port* + "No test matching provided target, runname pattern and test pattern found.")) + ((file-exists? destpath) + (debug:print-error 0 *default-log-port* + "Destination path alread exists! Please remove it before running get.")) + (else + (let loop ((rem-tests tests)) + (let* ((test-dat (common:get-youngest-test rem-tests)) + (item-path (db:test-get-item-path test-dat)) + (test-name (db:test-get-testname test-dat)) + (test-id (db:test-get-id test-dat)) + (run-id (db:test-get-run_id test-dat)) + (run-name (rmt:get-run-name-from-id run-id)) + (keyvals (rmt:get-key-val-pairs run-id)) + (target (string-intersperse (map cadr keyvals) "/")) + + (toplevel/children (and (db:test-get-is-toplevel test-dat) + (> (rmt:test-toplevel-num-items run-id test-name) 0))) + (test-partial-path (conc target "/" run-name "/" + (db:test-make-full-name test-name item-path))) + ;; note the trailing slash to get the dir inspite of it being a link + (test-path (conc linktree "/" test-partial-path)) + (archive-block-id (db:test-get-archived test-dat)) + (archive-block-info (rmt:test-get-archive-block-info archive-block-id)) + (archive-path (if (vector? archive-block-info) + (vector-ref archive-block-info 2) + #f)) + (archive-internal-path (conc (common:get-testsuite-name) "-" run-id + "/latest/" test-partial-path)) + (include-paths (args:get-arg "-include")) + (exclude-pattern (args:get-arg "-exclude-rx")) + (exclude-file (args:get-arg "-exclude-rx-from"))) + + (if (and archive-path ;; no point in proceeding if there is no actual archive + (not toplevel/children)) + (begin + (let* ((bup-restore-params (append (list "-d" archive-path "restore" "-C" (or destpath "data")) + ;; " " ;; What is the empty string for? + (if include-paths + (map (lambda (p) + (conc archive-internal-path "/" p)) + (string-split include-paths ",")) + (list archive-internal-path))))) + (debug:print-info 0 *default-log-port* "Restoring archived data to " (or destpath "data") + " from archive in " archive-path " ... " archive-internal-path) + (run-n-wait bup-exe params: bup-restore-params print-cmd: #t))) + (let ((new-rem-tests (filter (lambda (tdat) + (or (not (eq? (db:test-get-id tdat) test-id)) + (not (eq? (db:test-get-run_id tdat) run-id)))) + rem-tests) )) + (debug:print-info 0 *default-log-port* + "No archive path in the record for run-id=" run-id + " test-id=" test-id ", skipping.") + (if (null? new-rem-tests) + (begin + (debug:print-info 0 *default-log-port* "No archives found for " target "/" run-name "...") + #f) + (loop new-rem-tests))))))))))) + ADDED autostuff/.mtutil.scm Index: autostuff/.mtutil.scm ================================================================== --- /dev/null +++ autostuff/.mtutil.scm @@ -0,0 +1,88 @@ +;; Copyright 2006-2017, Matthew Welland. +;; +;; This file is part of Megatest. +;; +;; Megatest is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. +;; +;; Megatest is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with Megatest. If not, see . + +(use json) +(use ducttape-lib) + +(define (get-last-runname area-path target) + (let* ((run-data (with-input-from-pipe (conc "megatest -list-runs % -target " target " -fields runs:runname,event_time -dumpmode sexpr -start-dir " area-path) + read))) + (if (or (not run-data) + (null? run-data)) + #f + (let* ((name-time (let ((dat (map cdadr (alist-ref target run-data equal?)))) ;; (("runname" . "2017w07.0-0047") ("event_time" . "1487490424")) + ;; (print "dat=" dat) + (map (lambda (item) + (cons (alist-ref "runname" item equal?) + (string->number (alist-ref "event_time" item equal?)))) + dat))) + (sorted (sort name-time (lambda (a b)(> (cdr a)(cdr b))))) + (last-name (if (null? sorted) + #f + (caar sorted)))) + last-name)))) + +(define (str-first-char->number str) + (char->integer (string-ref str 0))) + +;; example of how to set up and write target mappers +;; NOTE: maps a *list* of targets! +;; +;; (? target run-name area area-path reason contour mode-patt) +;; +(add-target-mapper 'prefix-contour + (lambda (runkey area contour) + (print "target: " runkey) + (list (conc contour "/" runkey)))) +#;(add-target-mapper 'prefix-area-contour + (lambda (target run-name area area-path reason contour mode-patt) + (conc area "/" contour "/" target))) + +(add-runname-mapper 'corporate-ww + (lambda (target run-name area area-path reason contour mode-patt) + (print "corporate-ww called with: target=" target " run-name=" run-name " area=" area " area-path=" area-path " reason=" reason " contour=" contour " mode-patt=" mode-patt) + (let* ((last-name (get-last-runname area-path target)) + (last-letter (let* ((ch (if (string? last-name) + (let ((len (string-length last-name))) + (substring last-name (- len 1) len)) + "a")) + (chnum (str-first-char->number ch)) + (a (str-first-char->number "a")) + (z (str-first-char->number "z"))) + (if (and (>= chnum a)(<= chnum z)) + chnum + #f))) + (next-letter (if last-letter + (list->string + (list + (integer->char + (+ last-letter 1)))) ;; surely there is an easier way? + "a"))) + ;; (print "last-name: " last-name " last-letter: " last-letter " next-letter: " next-letter) + (conc (seconds->wwdate (current-seconds)) next-letter)))) + +(add-runname-mapper 'auto + (lambda (target run-name area area-path reason contour mode-patt) + "auto-eh")) + +;; run only areas where first letter of area name is "a" +;; +(add-area-checker 'first-letter-a + (lambda (area target contour) + (string-match "^a.*$" area))) + + ADDED autostuff/megatest.config Index: autostuff/megatest.config ================================================================== --- /dev/null +++ autostuff/megatest.config @@ -0,0 +1,85 @@ +# Copyright 2006-2017, Matthew Welland. +# +# This file is part of Megatest. +# +# Megatest is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# Megatest is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with Megatest. If not, see . + +## commented out due to a bug in v1.6501 in mtutil +[fields] +a text +b text +c text + +[default] +# usercode .mtutil.scm +# areafilter area-to-run +# targtrans generic-target-translator +# runtrans generic-runname-translator +usercode .mtutil.scm +# areafilter area-to-run +targtrans prefix-contour-broken +# runtrans generic-runname-translator + +[setup] +pktsdirs /mfs/home/matt/orion_automation/pkts + +[areas] + +# path-to-area map-target-script(future, optional) +# someqa path=../megatestqa/someqa; targtrans=somefunc; areafilter=area-to-run +# targtrans is name of scheme proc stored in .mtutil.scm, which lives in PWD where mtutil is run +# the target translator can return: a/target OR (list/of targets/to apply/run) +# OR #f i.e. run nothing + +# ext-tests path=ext-tests; targtrans=prefix-contour; + + +ext path=/mfs/home/matt/automation_areas/megatest/ext-tests; targtrans=prefix-contour + +[contours] +# selector=tag-expr/mode-patt +quick areas=ext; selector=/QUICKPATT +# quick2 areafn=check-area; selector=/QUICKPATT +full areas=ext +# quick areas=fullrun,ext-tests; selector=QUICKPATT/quick +# full areas=fullrun,ext-tests; selector=MAXPATT/ +# short areas=fullrun,ext-tests; selector=MAXPATT/ +# all areas=fullrun,ext-tests +# snazy selector=QUICKPATT/ + +[nopurpose] + +[access] +ext matt:admin mattw:owner + +[accesstypes] +admin run rerun resume remove set-ss rerun-clean +owner run rerun resume remove rerun-all +badguy set-ss + +[setup] +maxload 1.2 + +[listeners] +localhost:12345 contact=matt@kiatoa.com +localhost:54321 contact=matt@kiatoa.com + +[listener] +script nbfake echo + + +[server] +timeout 1 + +[include local.config] ADDED autostuff/runconfigs.config Index: autostuff/runconfigs.config ================================================================== --- /dev/null +++ autostuff/runconfigs.config @@ -0,0 +1,112 @@ +# Copyright 2006-2017, Matthew Welland. +# +# This file is part of Megatest. +# +# Megatest is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# Megatest is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with Megatest. If not, see . + +# To get emacs font highlighing in the various megatest configs do this: +# +# Install emacs-goodies-el: +# sudo apt install emacs-goodies-el +# Add to your ~/.emacs file: +# (add-to-list 'auto-mode-alist '("config\\'" . conf-space-mode)) +# + +# example of a cron entry to run sync using db spec pgdb, with pgdb setting in file local.config +# +[a/b/c] +# all:scheduled:sync cron= 0/5 * * * *;dbdest=pgdb;appendconf=/nfs/phoebe/disk1/home/mfs/matt/.sysmaint/local.config +# quick:scheduled:sync cron= 0/5 * * * *;dbdest=pgdb;appendconf=/nfs/phoebe/disk1/home/mfs/matt/.sysmaint/local.config +# fast:scheduled:sync-prepend cron= 0/1 * * * *;dbdest=pgdb;appendconf=/mfs/matt/.sysmaint/local.config + +# [scriptinc ./gentargets.sh #{getenv USER}] +# [v1.23/45/67] + +# tip will be replaced with hashkey? + +# [%/%/%] doesn't work + +[/.*/] + +[v1.65/tip/dev] +# file: files changes since last run trigger new run +# script: script is called with unix seconds as last parameter (other parameters are preserved) +# +# contour:sensetype:action params data +# commented out for debug + +quick:file:run runtrans=auto; glob=/nfs/orion/disk1/mfs_home/home/matt/automation_areas/megatest/*.scm foo.touchme +# snazy:file:run runtrans=corporate-ww; glob=/home/matt/data/megatest/*.scm +# short:file:run runtrans=short; glob=/home/matt/data/megatest/*.scm + +# script returns change-time (unix epoch), new-target-name, run-name +# +# quick:script:run checkfossil = http://www.kiatoa.com/fossils/megatest v1.63;\ +# checkfossil = http://www.kiatoa.com/fossils/megatest_qa trunk + +# # fossil based trigger +# # +quick:fossil:run http://www.kiatoa.com/fossils/megatest=v1.65;\ + http://www.kiatoa.com/fossils/megatest_qa=trunk + +# field allowed values +# ----- -------------- +# minute 0-59 +# hour 0-23 +# day of month 1-31 +# month 1-12 (or names, future development) +# day of week 0-7 (0 or 7 is Sun, or, future development, use names) + +# actions: +# run - run a testsuite +# clean - clear out runs +# archive - archive runs + +# quick:scheduled:run cron=47 * * * * ;run-name=auto +# quick:scheduled:archive cron=15 20 * * * ;run-name=%;target=%/%/% + +# [%] +# # every friday at midnight clean "all" tests over 7d +# all:scheduled:clean cron= 0 0 0 0 5;run-name=%;age=7d + +[v1.65/tip/dev] +# # file: files changes since last run trigger new run +# # script: script is called with unix seconds as last parameter (other parameters are preserved) +# # +# # contour:sensetype:action params data +# quick:file:run run-name=auto;glob=*.scm +# quick:file:clean run-name=auto; +# quick:script:run run-name=auto;script=checkfossil.sh v1.63 +# +# # field allowed values +# # ----- -------------- +# # minute 0-59 +# # hour 0-23 +# # day of month 1-31 +# # month 1-12 (or names, future development) +# # day of week 0-7 (0 or 7 is Sun, or, future development, use names) +# +# # actions: +# # run - run a testsuite +# # clean - clear out runs +# # archive - archive runs +# +quick:scheduled:run cron=47 * * * * ;run-name=auto +# quick:scheduled:archive cron=15 20 * * * ;run-name=% ; +# + +[%/%/%] +# # every friday at midnight clean "all" tests over 7d +all:scheduled:clean cron= 0 0 0 0 5;run-name=%;age=7d +# ADDED autostuff/setup.sh Index: autostuff/setup.sh ================================================================== --- /dev/null +++ autostuff/setup.sh @@ -0,0 +1,2 @@ +source /opt/chicken/4.13.0_18.04_WW45/setup-chicken4x.sh +export PATH=/mfs/home/matt/orion_automation/bin:$PATH DELETED batchsim/Makefile Index: batchsim/Makefile ================================================================== --- batchsim/Makefile +++ /dev/null @@ -1,8 +0,0 @@ -RUN=default.scm - -all : batchsim - ./batchsim $(RUN) - -batchsim : batchsim.scm - csc batchsim.scm - DELETED batchsim/batchsim.scm Index: batchsim/batchsim.scm ================================================================== --- batchsim/batchsim.scm +++ /dev/null @@ -1,417 +0,0 @@ -(use ezxdisp srfi-18) - -(define *ezx* (ezx-init 650 650 "Batch simulator")) -(require-library ezxgui) -(define *green* (make-ezx-color 0 1 0)) -(define *black* (make-ezx-color 0 0 0)) -(define *grey* (make-ezx-color 0.1 0.1 0.1)) -(define *blue* (make-ezx-color 0 0 1)) -(define *cyan* (make-ezx-color 0 1 1)) -(define *green* (make-ezx-color 0 1 0)) -(define *purple* (make-ezx-color 1 0 1)) -(define *red* (make-ezx-color 1 0 0)) -(define *white* (make-ezx-color 1 1 1)) -(define *yellow* (make-ezx-color 1 1 0)) - -(define *user-colors-palette* - (list - *green* - *blue* - *cyan* - *purple* - *red* - *yellow* - *black*)) - -(define *dark-green* (get-color "dark-green")) -(define *brown* (get-color "brown")) - -(ezx-select-layer *ezx* 1) -(ezx-wipe-layer *ezx* 1) - -;; (ezx-str-2d *ezx* 30 30 "Hello" *white*) -;; (ezx-fillrect-2d *ezx* 100 100 120 120 *brown*) -(ezx-redraw *ezx*) - -(define *last-draw* (current-milliseconds)) -(define *draw-delta* 40) ;; milliseconds between drawing - -(define (wait-for-next-draw-time) - (let* ((cm (current-milliseconds)) - (delta (- *draw-delta* (- cm *last-draw*)))) - (if (> delta 0) - (thread-sleep! (/ delta 1000))) - (set! *last-draw* (current-milliseconds)))) - -(include "events.scm") - -;; System spec (to be moved into loaded file) -;; -;; x y w gap x-min x-max -(define *cpu-grid* (vector 500 50 15 2 500 600)) -(define (make-cpu:grid)(make-vector 6)) -(define *queues* (make-hash-table)) ;; name -> (list (list user duration num-cpus num-gigs) ... ) -(define *cpus* (make-hash-table)) ;; cpu-name => (vector user job-len num-cpu mem x-loc y-loc) -(define *obj-locations* (make-hash-table)) ;; name -> (x y layer) -(define *queue-spec* - (vector - 80 ;; start-x - 300 ;; start-y - 300 ;; delta-y how far to next queue - 15 ;; height - 400 ;; length - )) -(define *use-log* #f) -(define *job-log-scale* 10) - -;;====================================================================== -;; CPU -;;====================================================================== - -(define-record cpu name num-cores mem job x y) - -;;====================================================================== -;; CPU Pool -;;====================================================================== - -(define-record pool name x y w h gap boxw cpus delta nrows ncols cpunum) - -(define (new-pool name x y nrows ncols gap boxw) - (let* ((delta (+ gap boxw)) - ;; (nrows (quotient h (+ gap delta))) - ;; (ncols (quotient w (+ gap delta))) - (w (+ gap (* nrows delta))) - (h (+ gap (* ncols delta))) - (cpus (make-vector (* nrows ncols) #f)) - (npool (make-pool name x y w h gap boxw cpus delta nrows ncols 0))) - npool)) - -(define (pool:add-cpu pool name num-cores mem) - (let* ((cpu (make-cpu name num-cores mem #f #f #f))) - (vector-set! (pool-cpus pool)(pool-cpunum pool) cpu) - (pool-cpunum-set! pool (+ 1 (pool-cpunum pool))) - cpu)) - -(define (pool:draw ezx pool) - (let ((nrows (pool-nrows pool)) - (ncols (pool-ncols pool)) - (x (pool-x pool)) - (y (pool-y pool)) - (w (pool-w pool)) - (h (pool-h pool)) - (gap (pool-gap pool)) - (boxw (pool-boxw pool)) - (delta (pool-delta pool)) - (cpus (pool-cpus pool))) - (ezx-select-layer ezx 1) - ;(ezx-wipe-layer ezx 1) - ;; draw time at upper right - (ezx-str-2d ezx x y (pool-name pool) *black*) - (ezx-rect-2d ezx x y (+ x w)(+ y h) *black* 1) - (let loop ((row 0) - (col 0) - (cpunum 0)) - (let* ((cpu (vector-ref cpus cpunum)) - (xval (+ x gap (* row delta))) - (yval (+ y gap (* col delta)))) - (if cpu - (begin - (cpu-x-set! cpu xval) - (cpu-y-set! cpu yval)) - (vector-set! cpus cpunum (make-cpu (conc cpunum) 1 1 #f xval yval))) - ;; (print "box at " xval ", " yval) - (ezx-rect-2d ezx xval yval (+ xval boxw) (+ yval boxw) *grey* 1) - (if (< col (- ncols 1)) - (loop row (+ col 1)(+ cpunum 1)) - (if (< row (- nrows 1)) - (loop (+ row 1) 0 (+ cpunum 1)))))) - (ezx-redraw ezx))) - - -;;====================================================================== -;; Users -;;====================================================================== - -(define *user-colors* (make-hash-table)) - -(define (get-user-color user) - (let ((color (hash-table-ref/default *user-colors* user #f))) - (if color - color - (let* ((color-num (+ (length (hash-table-keys *user-colors*)) 1)) - (color (list-ref *user-colors-palette* color-num))) - (hash-table-set! *user-colors* user color) - color)))) - -;;====================================================================== -;; Job Queues -;;====================================================================== - -;; jobs - -(define (make-queue:job)(make-vector 4)) -(define-inline (queue:job-get-user vec) (vector-ref vec 0)) -(define-inline (queue:job-get-duration vec) (vector-ref vec 1)) -(define-inline (queue:job-get-num-cpu vec) (vector-ref vec 2)) -(define-inline (queue:job-get-num-gigs vec) (vector-ref vec 3)) -(define-inline (queue:job-set-user! vec val)(vector-set! vec 0 val)) -(define-inline (queue:job-set-duration! vec val)(vector-set! vec 1 val)) -(define-inline (queue:job-set-num-cpu! vec val)(vector-set! vec 2 val)) -(define-inline (queue:job-set-num-gigs! vec val)(vector-set! vec 3 val)) - -;; add a job to the queue -;; -(define (add-job queue-name user duration num-cpu num-gigs) - (let* ((queue-dat (hash-table-ref/default *queues* queue-name '())) - (new-queue (append - queue-dat - (list (vector user duration num-cpu num-gigs))))) - (hash-table-set! *queues* queue-name new-queue) - (draw-queue-jobs queue-name))) - -;; peek for jobs to do in queue -;; -(define (peek-job queue-name) - (let ((queue (hash-table-ref/default *queues* queue-name '()))) - (if (null? queue) - #f - (car queue)))) - -;; take job from queue -;; -(define (take-job queue-name) - (let ((queue (hash-table-ref/default *queues* queue-name '()))) - (if (null? queue) - #f - (begin - (hash-table-set! *queues* queue-name (cdr queue)) - (draw-queue-jobs queue-name) - (car queue))))) - -;;====================================================================== -;; CPUs -;;====================================================================== - -(define (make-cpu:dat)(make-vector 6 #f)) -(define-inline (cpu:dat-get-user vec) (vector-ref vec 0)) -(define-inline (cpu:dat-get-job-len vec) (vector-ref vec 1)) -(define-inline (cpu:dat-get-num-cpu vec) (vector-ref vec 2)) -(define-inline (cpu:dat-get-mem vec) (vector-ref vec 3)) -(define-inline (cpu:dat-get-x vec) (vector-ref vec 4)) -(define-inline (cpu:dat-get-y vec) (vector-ref vec 5)) -(define-inline (cpu:dat-set-user! vec val)(vector-set! vec 0 val)) -(define-inline (cpu:dat-set-job-len! vec val)(vector-set! vec 1 val)) -(define-inline (cpu:dat-set-num-cpu! vec val)(vector-set! vec 2 val)) -(define-inline (cpu:dat-set-mem! vec val)(vector-set! vec 3 val)) -(define-inline (cpu:dat-set-x! vec val)(vector-set! vec 4 val)) -(define-inline (cpu:dat-set-y! vec val)(vector-set! vec 5 val)) - -(define-inline (cpu:grid-get-x vec) (vector-ref vec 0)) -(define-inline (cpu:grid-get-y vec) (vector-ref vec 1)) -(define-inline (cpu:grid-get-w vec) (vector-ref vec 2)) -(define-inline (cpu:grid-get-gap vec) (vector-ref vec 3)) -(define-inline (cpu:grid-get-x-min vec) (vector-ref vec 4)) -(define-inline (cpu:grid-get-x-max vec) (vector-ref vec 5)) -(define-inline (cpu:grid-set-x! vec val)(vector-set! vec 0 val)) -(define-inline (cpu:grid-set-y! vec val)(vector-set! vec 1 val)) -(define-inline (cpu:grid-set-w! vec val)(vector-set! vec 2 val)) -(define-inline (cpu:grid-set-gap! vec val)(vector-set! vec 3 val)) -(define-inline (cpu:grid-set-x-min! vec val)(vector-set! vec 4 val)) -(define-inline (cpu:grid-set-x-max! vec val)(vector-set! vec 5 val)) - -(define (add-cpu name num-cores mem) - (let ((x (cpu:grid-get-x *cpu-grid*)) - (y (cpu:grid-get-y *cpu-grid*)) - (delta (+ (cpu:grid-get-w *cpu-grid*)(cpu:grid-get-gap *cpu-grid*))) - (x-max (cpu:grid-get-x-max *cpu-grid*))) - (hash-table-set! *cpus* name (vector #f #f num-cores mem x y)) - (if (> x x-max) - (begin - (cpu:grid-set-x! *cpu-grid* (cpu:grid-get-x-min *cpu-grid*)) - (cpu:grid-set-y! *cpu-grid* (+ y delta))) - (cpu:grid-set-x! *cpu-grid* (+ x delta))))) - -;; draw grey box for each cpu on layer 2 -;; jobs are drawn on layer 1 -;; -(define (draw-cpus) ;; call once after init'ing all cpus - (ezx-select-layer *ezx* 1) - (ezx-wipe-layer *ezx* 1) - ;; draw time at upper right - (ezx-str-2d *ezx* 20 20 (seconds->h:m:s *now*) *black*) - (for-each - (lambda (cpu) - (let ((x (cpu:dat-get-x cpu)) - (y (cpu:dat-get-y cpu)) - (w (cpu:grid-get-w *cpu-grid*))) - (ezx-rect-2d *ezx* x y (+ x w) (+ y w) *grey* 1))) - (hash-table-values *cpus*)) - (ezx-redraw *ezx*)) - -(define (draw-jobs) - ;; (draw-cpus) - (ezx-select-layer *ezx* 2) - (ezx-wipe-layer *ezx* 2) - (for-each - (lambda (cpu) - (let* ((x (cpu:dat-get-x cpu)) - (y (cpu:dat-get-y cpu)) - (w (cpu:grid-get-w *cpu-grid*)) - (u (cpu:dat-get-user cpu))) - (if u ;; job running if not #f - (let ((color (get-user-color u))) - (ezx-fillrect-2d *ezx* (+ x 2)(+ 2 y)(+ x 9) (+ y 9) color))))) - (hash-table-values *cpus*)) - (ezx-redraw *ezx*)) - -(define (end-job cpu-name user) - (let ((cpu (hash-table-ref/default *cpus* cpu-name #f))) - (if cpu - (let ((curr-user (cpu:dat-get-user cpu))) ;; if it is a user name then job is not done - error - (if (or (not curr-user) - (not (equal? curr-user user))) - (print "ERROR: cpu " cpu-name " not running job for " user "!") - (begin - (cpu:dat-set-user! cpu #f) - (cpu:dat-set-job-len! cpu #f) - (draw-jobs)))) ;; hash-table-set! *cpus* cpu-name (make-cpu:dat)))) - (print "ERROR: no cpu " cpu-name " found. Ensure it is registered before addressing it.")))) - -(define (run-job cpu-name job) - (let* ((user (queue:job-get-user job)) - (job-len (queue:job-get-duration job)) - (cpu (hash-table-ref/default *cpus* cpu-name #f))) - (if cpu - (let ((curr-user (cpu:dat-get-user cpu))) ;; if it is a user name then job is not done - error - (if curr-user - (begin - (print "ERROR: cpu already busy! Adding more jobs not supported yet. " cpu-name) - #f) - (begin - (cpu:dat-set-user! cpu user) - (cpu:dat-set-job-len! cpu job-len) - (draw-jobs) - (hash-table-set! *cpus* cpu-name cpu) - (event (+ *now* job-len) (lambda ()(end-job cpu-name user))) - #t))) - #f))) - -(define (get-cpu) - (let ((all-cpus (hash-table-keys *cpus*))) - (if (null? all-cpus) - #f - (let loop ((hed (car all-cpus)) - (tal (cdr all-cpus))) - (if (cpu:dat-get-user (hash-table-ref/default *cpus* hed '(#f #f))) ;; if user is #f then cpu is available - (if (null? tal) - #f - (loop (car tal)(cdr tal))) - hed))))) - -;;====================================================================== -;; Animation -;;====================================================================== - -;; make-vector-record queue spec x y delta-y height length -(define (make-queue:spec)(make-vector 5)) -(define-inline (queue:spec-get-x vec) (vector-ref vec 0)) -(define-inline (queue:spec-get-y vec) (vector-ref vec 1)) -(define-inline (queue:spec-get-delta-y vec) (vector-ref vec 2)) -(define-inline (queue:spec-get-height vec) (vector-ref vec 3)) -(define-inline (queue:spec-get-length vec) (vector-ref vec 4)) -(define-inline (queue:spec-set-x! vec val)(vector-set! vec 0 val)) -(define-inline (queue:spec-set-y! vec val)(vector-set! vec 1 val)) -(define-inline (queue:spec-set-delta-y! vec val)(vector-set! vec 2 val)) -(define-inline (queue:spec-set-height! vec val)(vector-set! vec 3 val)) -(define-inline (queue:spec-set-length! vec val)(vector-set! vec 4 val)) - -;; queues are drawn on layer 3 but boxes (jobs) are drawn on the numbered layer -;; -(define (draw-queues) - (let* ((text-offset 3) - (queue-names (sort (hash-table-keys *queues*) string>=?)) - (start-x (vector-ref *queue-spec* 0)) - (text-x (+ start-x text-offset)) - (delta-y (vector-ref *queue-spec* 1)) - (delta-x (vector-ref *queue-spec* 2)) - (height (vector-ref *queue-spec* 3)) - (length (vector-ref *queue-spec* 4)) - (end-x (+ start-x length))) - (ezx-select-layer *ezx* 3) - (ezx-wipe-layer *ezx* 3) - (let loop ((y (vector-ref *queue-spec* 1)) - (qname (car queue-names)) - (tail (cdr queue-names)) - (layer 4)) - (print "Drawing queue at x=" start-x ", y=" y) - (ezx-fillrect-2d *ezx* start-x y end-x (+ y height) *brown*) - (ezx-str-2d *ezx* text-x (- (+ y height) text-offset) qname *white*) - (hash-table-set! *obj-locations* qname (list start-x y layer)) - (if (not (null? tail)) - (loop (+ y height delta-y) - (car tail) - (cdr tail) - (+ layer 1)))) - (ezx-redraw *ezx*))) - -;; compress queue data to (vector user count) list -;; -(define (draw-queue-compress-queue-data queue-dat) - (let loop ((hed (car queue-dat)) - (tal (cdr queue-dat)) - (curr #f) ;; (vector name count) - (res '())) - (let ((user (queue:job-get-user hed))) - (cond - ((not curr) ;; first time through only? - (if (null? tal) - (append res (list (vector user 1))) - (loop (car tal)(cdr tal)(vector user 1) res))) - ((equal? (vector-ref curr 0) user) - (vector-set! curr 1 (+ (vector-ref curr 1) 1)) - (if (null? tal) - (append res (list curr)) - (loop (car tal)(cdr tal) curr res))) - (else ;; names are different, add curr to queue and create new curr - (let ((newcurr (vector user 1))) - (if (null? tal) - (append res (list newcurr)) - (loop (car tal)(cdr tal) newcurr (append res (list curr)))))))))) - -;; draw jobs for a given queue -;; -(define (draw-queue-jobs queue-name) - (let* ((queue-dat (hash-table-ref/default *queues* queue-name #f)) ;; list of jobs in the queue - (obj-spec (hash-table-ref/default *obj-locations* queue-name #f))) ;; x, y etc. of the drawn queue - (if obj-spec - (let ((origin-x (list-ref obj-spec 0)) - (origin-y (list-ref obj-spec 1)) - (bar-width 10) - (queue-len (queue:spec-get-length *queue-spec*)) - (layer (list-ref obj-spec 2))) - (ezx-select-layer *ezx* layer) - (ezx-wipe-layer *ezx* layer) - (if (not (null? queue-dat)) - (let ((res (draw-queue-compress-queue-data queue-dat))) - (if (not (null? res)) - (let loop ((hed (car res)) - (tal (cdr res)) - (x2 (+ origin-x queue-len))) - (let* ((user (vector-ref hed 0)) - (h (let ((numjobs (vector-ref hed 1))) - (if *use-log* - (inexact->exact (round (log (+ 1 (* *job-log-scale* numjobs))))) - numjobs))) - (x1 (- x2 bar-width)) - (y2 (- origin-y h))) - ;; (print "x1 " x1 ", origin-y " origin-y ", x2 " x2 ", y2 " y2) - (ezx-fillrect-2d *ezx* x1 y2 x2 origin-y (get-user-color user)) - (if (not (null? tal)) - (loop (car tal)(cdr tal) x1))))) - (ezx-redraw *ezx*))))))) - -(let* ((args (argv)) - (fname (if (> (length args) 1) - (cadr args) - "default.scm"))) - (load (if (file-exists? fname) fname "default.scm"))) DELETED batchsim/default.scm Index: batchsim/default.scm ================================================================== --- batchsim/default.scm +++ /dev/null @@ -1,133 +0,0 @@ -;; run sim for four hours -;; -(define *end-time* (* 60 50)) - -;; create the cpus -;; -(let loop ((count 200)) - (add-cpu (conc "cpu_" count) 1 1) - (if (>= count 0)(loop (- count 1)))) - -(draw-cpus) - -(define *pool1* (new-pool "generic" 100 100 100 100 2 10)) -(let loop ((count 10)) - (pool:add-cpu *pool1* (conc count) 1 1) - (if (> count 0) - (loop (- count 1)))) - -(pool:draw *ezx* *pool1*) - -;; init the queues -;; -(hash-table-set! *queues* "normal" '()) -(hash-table-set! *queues* "quick" '()) -(draw-queues) - -;; user k adds 200 jobs at time zero -;; -(event *start-time* - (lambda () - (let loop ((count 300)) ;; add 500 jobs - (add-job "normal" "k" 600 1 1) - (if (>= count 0)(loop (- count 1)))))) - -;; one minute in user m runs ten jobs -;; -(event (+ 600 *start-time*) - (lambda () - (let loop ((count 300)) ;; add 100 jobs - (add-job "normal" "m" 600 1 1) - (if (> count 0)(loop (- count 1)))))) - -;; every minute user j runs ten jobs -;; -(define *user-j-jobs* 300) -(event (+ 600 *start-time*) - (lambda () - (let f () - (schedule 60) - (if (> *user-j-jobs* 0) - (begin - (let loop ((count 5)) ;; add 100 jobs - (add-job "quick" "j" 600 1 1) - (if (> count 0)(loop (- count 1)))) - (set! *user-j-jobs* (- *user-j-jobs* 5)))) - (if (and (not *done*) - (> *user-j-jobs* 0)) - (f))))) ;; Megatest user running 200 jobs - -;; every minute user j runs ten jobs -;; -(define *user-j-jobs* 300) -(event (+ 630 *start-time*) - (lambda () - (let f () - (schedule 60) - (if (> *user-j-jobs* 0) - (begin - (let loop ((count 5)) ;; add 100 jobs - (add-job "quick" "n" 600 1 1) - (if (> count 0)(loop (- count 1)))) - (set! *user-j-jobs* (- *user-j-jobs* 5)))) - (if (and (not *done*) - (> *user-j-jobs* 0)) - (f))))) ;; Megatest user running 200 jobs - -;; ;; -;; (event *start-time* -;; (lambda () -;; (let f ((count 200)) -;; (schedule 10) -;; (add-job "normal" "t" 60 1 1) -;; (if (and (not *done*) -;; (>= count 0)) -;; (f (- count 1)))))) - -;; every 3 seconds check for available machines and launch a job -;; -(event *start-time* - (lambda () - (let f () - (schedule 3) - (let ((queue-names (random-sort (hash-table-keys *queues*)))) - (let loop ((cpu (get-cpu)) - (count (+ (length queue-names) 4)) - (qname (car queue-names)) - (remq (cdr queue-names))) - (if (and cpu - (> count 0)) - (begin - (if (peek-job qname) ;; any jobs to do in normal queue - (let ((job (take-job qname))) - (run-job cpu job))) - (loop (get-cpu) - (- count 1) - (if (null? remq) - (car queue-names) - (car remq)) - (if (null? remq) - (cdr queue-names) - (cdr remq))))))) - (if (not *done*)(f))))) - -;; screen updates -;; -(event *start-time* (lambda () - (let f () - (schedule 60) ;; update the screen every 60 seconds of sim time - (draw-cpus) ;; (print "Now: " *now* " queue: " (hash-table->alist *queues*)) - (wait-for-next-draw-time) - (if (not *done*) (f))))) - - -;; end the simulation -;; -(event *end-time* - (lambda () - (set! *event-list* '()) - (set! *done* #t))) - -(start) -;; (exit 0) - DELETED batchsim/events.scm Index: batchsim/events.scm ================================================================== --- batchsim/events.scm +++ /dev/null @@ -1,79 +0,0 @@ - -;;====================================================================== -;; Event Processing and Simulator -;;====================================================================== - -;; The global event list -(define *event-list* '()) -(define *start-time* 0) -(define *end-time* (* 60 60 4)) ;; four hours -(define *now* *start-time*) -(define *done* #f) - -(define (random-sort l) - (sort l - (lambda (x y) - (equal? 0 (random 2))))) - -;; Each item in the event list is a list of a scheduled time and the thunk -;; (time thunk). Sort the list so that the next event is the earliest. -;; -(define event-sort - (lambda (@a @b) - (< (car @a)(car @b)))) - -(define event - (lambda ($time $thunk) ;; add a sort based on scheduled time here -- improve later - ;; to use an insert algorythm. - (set! *event-list* (sort (cons (list $time $thunk) *event-list*) event-sort)))) - -(define start - (lambda () - (let ((next (car *event-list*))) - (set! *event-list* (cdr *event-list*)) - (set! *now* (car next)) - (if (not *done*) ;; note that the second item in the list is the thunk - ((car (cdr next))))))) - -(define pause - (lambda () - (call/cc - (lambda (k) - (event (lambda () (k #f))) - (start))))) - -(define schedule - (lambda ($time) - (call/cc - (lambda (k) - (event (+ *now* $time) (lambda () (k #f))) - (start))))) - -;; (event (lambda () (let f () (pause) (display "h") (f)))) - -(define years->seconds - (lambda ($yrs) - (* $yrs 365 24 3600))) - -(define weeks->seconds - (lambda ($wks) - (* $wks 7 24 3600))) - -(define days->seconds - (lambda ($days) - (* $days 24 3600))) - -(define months->seconds - (lambda ($months) - (* $months (/ 365 12) 24 3600))) - -(define seconds->date - (lambda ($seconds) - (posix-strftime "%D" (posix-localtime (inexact->exact $seconds))))) - -(define (seconds->h:m:s seconds) - (let* ((hours (quotient seconds 3600)) - (rem1 (- seconds (* hours 3600))) - (minutes (quotient rem1 60)) - (rem-sec (- rem1 (* minutes 60)))) - (conc hours "h " minutes "m " rem-sec "s"))) DELETED batchsim/testing.scm Index: batchsim/testing.scm ================================================================== --- batchsim/testing.scm +++ /dev/null @@ -1,135 +0,0 @@ -;; run sim for four hours -;; -(define *end-time* (* 60 50)) - -;; create the cpus -;; -(let loop ((count 200)) - (add-cpu (conc "cpu_" count) 1 1) - (if (>= count 0)(loop (- count 1)))) - -;; (draw-cpus) - -(define *pool1* (new-pool "generic" 20 20 12 80 2 4)) -(let loop ((count 10)) - (pool:add-cpu *pool1* (conc count) 1 1) - (if (> count 0) - (loop (- count 1)))) - -(pool:draw *ezx* *pool1*) - -;; ;; init the queues -;; ;; -;; (hash-table-set! *queues* "normal" '()) -;; (hash-table-set! *queues* "quick" '()) -;; (draw-queues) -;; -;; ;; user k adds 200 jobs at time zero -;; ;; -;; (event *start-time* -;; (lambda () -;; (let loop ((count 300)) ;; add 500 jobs -;; (add-job "normal" "k" 600 1 1) -;; (if (>= count 0)(loop (- count 1)))))) -;; -;; ;; one minute in user m runs ten jobs -;; ;; -;; (event (+ 600 *start-time*) -;; (lambda () -;; (let loop ((count 300)) ;; add 100 jobs -;; (add-job "normal" "m" 600 1 1) -;; (if (> count 0)(loop (- count 1)))))) -;; -;; ;; every minute user j runs ten jobs -;; ;; -;; (define *user-j-jobs* 300) -;; (event (+ 600 *start-time*) -;; (lambda () -;; (let f () -;; (schedule 60) -;; (if (> *user-j-jobs* 0) -;; (begin -;; (let loop ((count 5)) ;; add 100 jobs -;; (add-job "quick" "j" 600 1 1) -;; (if (> count 0)(loop (- count 1)))) -;; (set! *user-j-jobs* (- *user-j-jobs* 5)))) -;; (if (and (not *done*) -;; (> *user-j-jobs* 0)) -;; (f))))) ;; Megatest user running 200 jobs -;; -;; ;; every minute user j runs ten jobs -;; ;; -;; (define *user-j-jobs* 300) -;; (event (+ 630 *start-time*) -;; (lambda () -;; (let f () -;; (schedule 60) -;; (if (> *user-j-jobs* 0) -;; (begin -;; (let loop ((count 5)) ;; add 100 jobs -;; (add-job "quick" "n" 600 1 1) -;; (if (> count 0)(loop (- count 1)))) -;; (set! *user-j-jobs* (- *user-j-jobs* 5)))) -;; (if (and (not *done*) -;; (> *user-j-jobs* 0)) -;; (f))))) ;; Megatest user running 200 jobs -;; -;; ;; ;; -;; ;; (event *start-time* -;; ;; (lambda () -;; ;; (let f ((count 200)) -;; ;; (schedule 10) -;; ;; (add-job "normal" "t" 60 1 1) -;; ;; (if (and (not *done*) -;; ;; (>= count 0)) -;; ;; (f (- count 1)))))) -;; -;; ;; every 3 seconds check for available machines and launch a job -;; ;; -;; (event *start-time* -;; (lambda () -;; (let f () -;; (schedule 3) -;; (let ((queue-names (random-sort (hash-table-keys *queues*)))) -;; (let loop ((cpu (get-cpu)) -;; (count (+ (length queue-names) 4)) -;; (qname (car queue-names)) -;; (remq (cdr queue-names))) -;; (if (and cpu -;; (> count 0)) -;; (begin -;; (if (peek-job qname) ;; any jobs to do in normal queue -;; (let ((job (take-job qname))) -;; (run-job cpu job))) -;; (loop (get-cpu) -;; (- count 1) -;; (if (null? remq) -;; (car queue-names) -;; (car remq)) -;; (if (null? remq) -;; (cdr queue-names) -;; (cdr remq))))))) -;; (if (not *done*)(f))))) -;; -;; ;; screen updates -;; ;; -(event *start-time* (lambda () - (let f () - (schedule 60) ;; update the screen every 60 seconds of sim time - ;; (draw-cpus) ;; (print "Now: " *now* " queue: " (hash-table->alist *queues*)) - (pool:draw *ezx* *pool1*) - - (wait-for-next-draw-time) - (if (not *done*) (f))))) -;; -;; -;; ;; end the simulation -;; ;; -(event *end-time* - (lambda () - (set! *event-list* '()) - (set! *done* #t))) -;; -(start) -;; ;; (exit 0) -;; DELETED bin/sleeprunner Index: bin/sleeprunner ================================================================== --- bin/sleeprunner +++ /dev/null @@ -1,7 +0,0 @@ -#!/bin/bash - -if [[ $SLEEPRUNNER == "" ]];then -SLEEPRUNNER=0 -fi - -echo "nbfake $@ &> /dev/null" | at now + $SLEEPRUNNER minutes &> /dev/null ADDED cgisetup/models/pgdb.scm Index: cgisetup/models/pgdb.scm ================================================================== --- /dev/null +++ cgisetup/models/pgdb.scm @@ -0,0 +1,656 @@ +;;====================================================================== +;; Copyright 2017, Matthew Welland. +;; +;; This file is part of Megatest. +;; +;; Megatest is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. +;; +;; Megatest is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with Megatest. If not, see . + +;;====================================================================== + +(declare (unit pgdb)) +(declare (uses configf)) + +;; I don't know how to mix compilation units and modules, so no module here. +;; +;; (module pgdb +;; ( +;; open-pgdb +;; ) +;; +;; (import scheme) +;; (import data-structures) +;; (import chicken) + +(use typed-records (prefix dbi dbi:)) + +;; given a configdat lookup the connection info and open the db +;; +(define (pgdb:open configdat #!key (dbname #f)(dbispec #f)) + (let ((pgconf (or dbispec + (args:get-arg "-pgsync") + (if configdat + (configf:lookup configdat "ext-sync" (or dbname "pgdb")) + #f) + ))) + (if pgconf + (let* ((confdat (map (lambda (conf-item) + (let ((parts (string-split conf-item ":"))) + (if (> (length parts) 1) + (let ((key (car parts)) + (val (cadr parts))) + (cons (string->symbol key) val)) + (begin + (print "ERROR: Bad config setting " conf-item ", should be key:val") + `(,(string->symbol (car parts)) . #f))))) + (string-split pgconf))) + (dbtype (string->symbol (or (alist-ref 'dbtype confdat) "pg")))) + (if (alist-ref 'dbtype confdat) + (dbi:open dbtype (alist-delete 'dbtype confdat)))) + #f))) + +;;====================================================================== +;; A R E A S +;;====================================================================== + +(defstruct area id area-name area-path last-update) + +(define (pgdb:add-area dbh area-name area-path) + (dbi:exec dbh "INSERT INTO areas (area_name,area_path) VALUES (?,?)" area-name area-path)) + +(define (pgdb:get-areas dbh) + ;; (map + ;; (lambda (row) + ;; (print "row: " row)) + (dbi:get-rows dbh "SELECT id,area_name,area_path,last_sync FROM areas;")) ;; ) + +;; given an area_path get the area info +;; +(define (pgdb:get-area-by-path dbh area-path) + (dbi:get-one-row dbh "SELECT id,area_name,area_path,last_sync FROM areas WHERE area_path=?;" area-path)) + +(define (pgdb:write-sync-time dbh area-info new-sync-time) + (let ((area-id (vector-ref area-info 0))) + (dbi:exec dbh "UPDATE areas SET last_sync=? WHERE id=?;" new-sync-time area-id))) + +;;====================================================================== +;; T A R G E T S +;;====================================================================== + +;; Given a target-spec, return the id. Should probably handle this with a join... +;; if target-spec not found, create a record for it. +;; +(define (pgdb:get-ttype dbh target-spec) + (let ((spec-id (dbi:get-one dbh "SELECT id FROM ttype WHERE target_spec=?;" target-spec))) + (or spec-id + (if (handle-exceptions + exn + (begin + (print-call-chain) + (debug:print 0 *default-log-port* "ERROR: cannot create ttype entry, " ((condition-property-accessor 'exn 'message) exn)) + #f) + (dbi:exec dbh "INSERT INTO ttype (target_spec) VALUES (?);" target-spec)) + (pgdb:get-ttype dbh target-spec))))) + +;;====================================================================== +;; T A G S +;;====================================================================== + + +(define (pgdb:get-tag-info-by-name dbh tag) + (dbi:get-one-row dbh "SELECT id,tag_name FROM tags where tag_name=?;" tag)) + +(define (pgdb:insert-tag dbh name ) + (dbi:exec dbh "INSERT INTO tags (tag_name) VALUES (?)" name )) + +(define (pgdb:insert-area-tag dbh tag-id area-id ) + (dbi:exec dbh "INSERT INTO area_tags (tag_id, area_id) VALUES (?,?)" tag-id area-id )) + +(define (pgdb:insert-run-tag dbh tag-id run-id ) + (dbi:exec dbh "INSERT INTO run_tags (tag_id, run_id) VALUES (?,?)" tag-id run-id )) + + +(define (pgdb:is-area-taged dbh area-id) + (let ((area-tag-id (dbi:get-one dbh "SELECT id FROM area_tags WHERE area_id=?;" area-id))) + (if area-tag-id + #t + #f))) + +(define (pgdb:is-area-taged-with-a-tag dbh tag-id area-id) + (let ((area-tag-id (dbi:get-one dbh "SELECT id FROM area_tags WHERE area_id=? and tag_id=?;" area-id tag-id))) + (if area-tag-id + #t + #f))) + +(define (pgdb:is-run-taged-with-a-tag dbh tag-id run-id) + (let ((run-tag-id (dbi:get-one dbh "SELECT id FROM run_tags WHERE run_id=? and tag_id=?;" run-id tag-id))) + (if run-tag-id + #t + #f))) + + + +;;====================================================================== +;; R U N S +;;====================================================================== + +;; given a target spec id, target and run-name return the run-id +;; if no run found return #f +;; +(define (pgdb:get-run-id dbh spec-id target run-name area-id) + (dbi:get-one dbh "SELECT id FROM runs WHERE ttype_id=? AND target=? AND run_name=? and area_id=?;" + spec-id target run-name area-id)) + +;; given a target spec id, target and run-name return the run-id +;; if no run found return #f +;; +(define (pgdb:get-run-last-update dbh id ) + (dbi:get-one dbh "SELECT last_update FROM runs WHERE id=?;" + id)) + +;; given a run-id return all the run info +;; +(define (pgdb:get-run-info dbh run-id ) ;; to join ttype or not? + (dbi:get-one-row + dbh ;; 0 1 2 3 4 5 6 7 8 9 10 11 12 + "SELECT id,target,ttype_id,run_name,state,status,owner,event_time,comment,fail_count,pass_count,last_update,area_id + FROM runs WHERE id=? ;" run-id )) + +;; refresh the data in a run record +;; +(define (pgdb:refresh-run-info dbh run-id state status owner event-time comment fail-count pass-count area-id last_update publish-time) ;; area-id) + (dbi:exec + dbh + "UPDATE runs SET + state=?,status=?,owner=?,event_time=?,comment=?,fail_count=?,pass_count=?,last_update=?,publish_time=? + WHERE id=? and area_id=?;" + state status owner event-time comment fail-count pass-count last_update publish-time run-id area-id )) + +;; given all needed info create run record +;; +(define (pgdb:insert-run dbh ttype-id target run-name state status owner event-time comment fail-count pass-count area-id last-update publish-time) + (dbi:exec + dbh + "INSERT INTO runs (ttype_id,target,run_name,state,status,owner,event_time,comment,fail_count,pass_count,area_id,last_update,publish_time) + VALUES (?,?,?,?,?,?,?,?,?,?,?,?, ?);" + ttype-id target run-name state status owner event-time comment fail-count pass-count area-id last-update publish-time)) + +;;====================================================================== +;; T E S T - S T E P S +;;====================================================================== + +(define (pgdb:get-test-step-id dbh test-id stepname state) + (dbi:get-one + dbh + "SELECT id FROM test_steps WHERE test_id=? AND stepname=? and state = ? ;" + test-id stepname state)) + +(define (pgdb:get-test-step-last-update dbh id ) + (dbi:get-one + dbh + "SELECT last_update FROM test_steps WHERE id=? ;" + id)) + +(define (pgdb:insert-test-step dbh test-id stepname state status event_time comment logfile last-update ) + (dbi:exec + dbh + "INSERT INTO test_steps (test_id,stepname,state,status,event_time,logfile,comment,last_update) + VALUES (?,?,?,?,?,?,?,? );" + test-id stepname state status event_time logfile comment last-update)) + +(define (pgdb:update-test-step dbh step-id test-id stepname state status event_time comment logfile last-update) + (dbi:exec + dbh + "UPDATE test_steps SET + test_id=?,stepname=?,state=?,status=?,event_time=?,logfile=?,comment=?,last_update=? + WHERE id=?;" + test-id stepname state status event_time logfile comment last-update step-id)) + + +;;====================================================================== +;; T E S T - D A T A +;;====================================================================== + +(define (pgdb:get-test-data-id dbh test-id category variable) + (dbi:get-one + dbh + "SELECT id FROM test_data WHERE test_id=? AND category=? and variable = ? ;" + test-id category variable)) + +(define (pgdb:get-test-data-last-update dbh test-data-id ) + (dbi:get-one + dbh + "SELECT last_update FROM test_data WHERE id=? ;" + test-data-id)) + +(define (pgdb:insert-test-data dbh test-id category variable value expected tol units comment status type last-update) + ; (print "INSERT INTO test_data (test_id, category, variable, value, expected, tol, units, comment, status, type) + ; VALUES (?,?,?,?,?,?,?,?,?,?) " test-id " " category " " variable " " value " " expected " " tol " " units " " comment " " status " " type) + (if (not (string? units)) + (set! units "" )) + (if (not (string? variable)) + (set! variable "" )) + (if (not (real? value)) + (set! value 0 )) + (if (not (real? expected)) + (set! expected 0 )) +(if (not (real? tol)) + (set! tol 0 )) + + (dbi:exec + dbh + "INSERT INTO test_data (test_id, category, variable, value, expected, tol, units, comment, status, type, last_update) + VALUES (?,?,?,?,?,?,?,?,?,?, ?);" + test-id category variable value expected tol units comment status type last-update)) + +(define (pgdb:update-test-data dbh data-id test-id category variable value expected tol units comment status type last-update) + (dbi:exec + dbh + "UPDATE test_data SET + test_id=?, category=?, variable=?, value=?, expected=?, tol=?, units=?, comment=?, status=?, type=?, last_update=? + WHERE id=?;" + test-id category variable value expected tol units comment status type last-update data-id )) + + + +;;====================================================================== +;; T E S T S +;;====================================================================== + +;; given run-id, test_name and item_path return test-id +;; +(define (pgdb:get-test-id dbh run-id test-name item-path) + (dbi:get-one + dbh + "SELECT id FROM tests WHERE run_id=? AND test_name=? AND item_path=?;" + run-id test-name item-path)) + +(define (pgdb:get-test-last-update dbh id) + (dbi:get-one + dbh + "SELECT last_update FROM tests WHERE id=? ;" + id )) + + +;; create new test record +;; +(define (pgdb:insert-test dbh run-id test-name item-path state status host cpuload diskfree uname run-dir log-file run-duration comment event-time archived last-update pid) + (dbi:exec + dbh + "INSERT INTO tests (run_id,test_name,item_path,state,status,host,cpuload,diskfree,uname,rundir,final_logf,run_duration,comment,event_time,archived,last_update,attemptnum) + VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?);" + + run-id test-name item-path state status host cpuload diskfree uname + run-dir log-file run-duration comment event-time archived last-update pid)) + +;; update existing test record +;; +(define (pgdb:update-test dbh test-id run-id test-name item-path state status host cpuload diskfree uname run-dir log-file run-duration comment event-time archived last-update pid) + (dbi:exec + dbh + "UPDATE tests SET + run_id=?,test_name=?,item_path=?,state=?,status=?,host=?,cpuload=?,diskfree=?,uname=?,rundir=?,final_logf=?,run_duration=?,comment=?,event_time=?,archived=?,last_update=?,attemptnum=? + WHERE id=?;" + + run-id test-name item-path state status host cpuload diskfree uname + run-dir log-file run-duration comment event-time archived last-update pid test-id)) + +(define (pgdb:get-tests dbh target-patt) + (dbi:get-rows + dbh + "SELECT t.id,t.run_id,t.test_name,t.item_path,t.state,t.status,t.host,t.cpuload,t.diskfree,t.uname,t.rundir,t.final_logf,t.run_duration,t.comment,t.event_time,t.archived, + r.id,r.target,r.ttype_id,r.run_name,r.state,r.status,r.owner,r.event_time,r.comment + FROM tests AS t INNER JOIN runs AS r ON t.run_id=r.id + WHERE r.target LIKE ?;" target-patt)) + +(define (pgdb:get-stats-given-type-target dbh ttype-id target-patt) + (dbi:get-rows + dbh + ;; "SELECT COUNT(t.id),t.status,r.target FROM tests AS t INNER JOIN runs AS r ON t.run_id=r.id + ;; WHERE t.state='COMPLETED' AND ttype_id=? AND r.target LIKE ? GROUP BY r.target,t.status;" + "SELECT r.target,COUNT(*) AS total, + SUM(CASE WHEN t.status='PASS' THEN 1 ELSE 0 END) AS pass, + SUM(CASE WHEN t.status='FAIL' THEN 1 ELSE 0 END) AS fail, + SUM(CASE WHEN t.status IN ('PASS','FAIL') THEN 0 ELSE 1 END) AS other + FROM tests AS t INNER JOIN runs AS r ON t.run_id=r.id + WHERE t.state='COMPLETED' AND ttype_id=? AND r.target LIKE ? GROUP BY r.target;" + ttype-id target-patt)) + +(define (pgdb:get-stats-given-target dbh target-patt) + (dbi:get-rows + dbh + ;; "SELECT COUNT(t.id),t.status,r.target FROM tests AS t INNER JOIN runs AS r ON t.run_id=r.id + ;; WHERE t.state='COMPLETED' AND ttype_id=? AND r.target LIKE ? GROUP BY r.target,t.status;" + "SELECT r.target,COUNT(*) AS total, + SUM(CASE WHEN t.status='PASS' THEN 1 ELSE 0 END) AS pass, + SUM(CASE WHEN t.status='FAIL' THEN 1 ELSE 0 END) AS fail, + SUM(CASE WHEN t.status IN ('PASS','FAIL') THEN 0 ELSE 1 END) AS other + FROM tests AS t INNER JOIN runs AS r ON t.run_id=r.id + WHERE t.state='COMPLETED' AND r.target LIKE ? GROUP BY r.target;" + target-patt)) + + +(define (pgdb:get-latest-run-stats-given-target dbh ttype-id target-patt limit offset) + (dbi:get-rows + dbh + ;; "SELECT COUNT(t.id),t.status,r.target FROM tests AS t INNER JOIN runs AS r ON t.run_id=r.id + ;; WHERE t.state='COMPLETED' AND ttype_id=? AND r.target LIKE ? GROUP BY r.target,t.status;" + "SELECT r.target, r.event_time, COUNT(*) AS total, + SUM(CASE WHEN t.status='PASS' THEN 1 ELSE 0 END) AS pass, + SUM(CASE WHEN t.status='FAIL' THEN 1 ELSE 0 END) AS fail, + SUM(CASE WHEN t.status IN ('PASS','FAIL') THEN 0 ELSE 1 END) AS other, r.id + FROM tests AS t INNER JOIN runs AS r ON t.run_id=r.id + WHERE t.state like '%' AND ttype_id=? AND r.target LIKE ? + and r.id in + (SELECT DISTINCT on (target) id from runs where target like ? AND ttype_id=? order by target,event_time desc) + GROUP BY r.target,r.id + order by r.event_time desc limit ? offset ? ;" + ttype-id target-patt target-patt ttype-id limit offset)) + +(define (pgdb:get-latest-run-stats-given-pattern dbh patt limit offset) + (dbi:get-rows + dbh + ;; "SELECT COUNT(t.id),t.status,r.target FROM tests AS t INNER JOIN runs AS r ON t.run_id=r.id + ;; WHERE t.state='COMPLETED' AND ttype_id=? AND r.target ILIKE ? GROUP BY r.target,t.status;" + "SELECT r.target, r.event_time, COUNT(*) AS total, + SUM(CASE WHEN t.status='PASS' THEN 1 ELSE 0 END) AS pass, + SUM(CASE WHEN t.status='FAIL' THEN 1 ELSE 0 END) AS fail, + SUM(CASE WHEN t.status IN ('PASS','FAIL') THEN 0 ELSE 1 END) AS other, r.id + FROM tests AS t INNER JOIN runs AS r ON t.run_id=r.id + WHERE t.state like '%' AND r.target ILIKE ? + and r.id in + (SELECT DISTINCT on (target) id from runs where target ilike ? order by target,event_time desc) + GROUP BY r.target,r.id + order by r.event_time desc limit ? offset ? ;" + patt patt limit offset)) + + +(define (pgdb:get-count-data-stats-target-latest dbh ttype-id target-patt) + (dbi:get-rows + dbh + "SELECT count(*) from + (SELECT DISTINCT on (target) id + from runs where target like ? AND ttype_id = ? + order by target, event_time desc + ) as x;" + target-patt ttype-id)) + +(define (pgdb:get-latest-run-cnt dbh ttype-id target-patt) + (let* ((cnt-result (pgdb:get-count-data-stats-target-latest dbh ttype-id target-patt)) + ;(cnt-row (car (cnt-result))) + (cnt 0) + ) + (for-each + (lambda (row) + (set! cnt (vector-ref row 0 ))) + cnt-result) + +cnt)) + +(define (pgdb:get-count-data-stats-latest-pattern dbh patt) + (dbi:get-rows + dbh + "SELECT count(*) from + (SELECT DISTINCT on (target) id + from runs where target ilike ? + order by target, event_time desc + ) as x;" + patt)) + +(define (pgdb:get-latest-run-cnt-by-pattern dbh target-patt) + (let* ((cnt-result (pgdb:get-count-data-stats-latest-pattern dbh target-patt)) + ;(cnt-row (car (cnt-result))) + (cnt 0) + ) + (for-each + (lambda (row) + (set! cnt (vector-ref row 0 ))) + cnt-result) + +cnt)) + + + + + +(define (pgdb:get-run-stats-history-given-target dbh ttype-id target-patt) + (dbi:get-rows + dbh + ;; "SELECT COUNT(t.id),t.status,r.target FROM tests AS t INNER JOIN runs AS r ON t.run_id=r.id + ;; WHERE t.state='COMPLETED' AND ttype_id=? AND r.target LIKE ? GROUP BY r.target,t.status;" + "SELECT r.run_name,COUNT(*) AS total, + SUM(CASE WHEN t.status='PASS' THEN 1 ELSE 0 END) AS pass, + SUM(CASE WHEN t.status='FAIL' THEN 1 ELSE 0 END) AS fail, + SUM(CASE WHEN t.status IN ('PASS','FAIL') THEN 0 ELSE 1 END) AS other + FROM tests AS t INNER JOIN runs AS r ON t.run_id=r.id + WHERE t.state like '%' AND ttype_id=? AND r.target LIKE ? + GROUP BY r.run_name;" + ttype-id target-patt )) + +(define (pgdb:get-all-run-stats-target-slice dbh target-patt limit offset) + (dbi:get-rows + dbh + "SELECT r.target, r.run_name,r.event_time, COUNT(*) AS total, + SUM(CASE WHEN t.status='PASS' THEN 1 ELSE 0 END) AS pass, + SUM(CASE WHEN t.status='FAIL' THEN 1 ELSE 0 END) AS fail, + SUM(CASE WHEN t.status IN ('PASS','FAIL') THEN 0 ELSE 1 END) AS other + FROM tests AS t INNER JOIN runs AS r ON t.run_id=r.id + WHERE r.target LIKE ? + GROUP BY r.target,r.run_name, r.event_time + order by r.target,r.event_time desc limit ? offset ? ;" + target-patt limit offset)) + + +(define (pgdb:get-count-data-stats-target-slice dbh target-patt) + (dbi:get-rows + dbh + "SELECT count(*) from (SELECT r.target, r.run_name,r.event_time, COUNT(*) AS total + FROM tests AS t INNER JOIN runs AS r ON t.run_id=r.id + WHERE r.target LIKE ? + GROUP BY r.target,r.run_name, r.event_time + ) as x;" + target-patt)) + +(define (pgdb:get-slice-cnt dbh target-patt) + (let* ((cnt-result (pgdb:get-count-data-stats-target-slice dbh target-patt)) + ;(cnt-row (car (cnt-result))) + (cnt 0) + ) + (for-each + (lambda (row) + (set! cnt (vector-ref row 0 ))) + cnt-result) + +cnt)) + + +(define (pgdb:get-target-types dbh) + (dbi:get-rows dbh "SELECT id,target_spec FROM ttype;")) + + (define (pgdb:get-distict-target-slice dbh) + (dbi:get-rows dbh " select distinct on (split_part (target, '/', 1)) (split_part (target, '/', 1)) from runs;")) + + (define (pgdb:get-distict-target-slice3 dbh) + (dbi:get-rows dbh " select distinct on (split_part (target, '/', 3)) (split_part (target, '/', 3)) from runs;")) +;; +(define (pgdb:get-targets dbh target-patt) + (let ((ttypes (pgdb:get-target-types dbh))) + (map + (lambda (ttype-dat) + (let ((tt-id (vector-ref ttype-dat 0)) + (ttype (vector-ref ttype-dat 1))) + (cons ttype + (dbi:get-rows + dbh + "SELECT DISTINCT target FROM runs WHERE target LIKE ? AND ttype_id=?;" target-patt tt-id)) + )) + ttypes))) + +(define (pgdb:get-targets-of-type dbh ttype-id target-patt) + (dbi:get-rows dbh "SELECT DISTINCT target FROM runs WHERE target LIKE ? AND ttype_id=?;" target-patt ttype-id)) + +(define (pgdb:get-runs-by-target dbh targets run-patt) + (dbi:get-rows dbh "SELECT r.run_name, t.test_name, t.status, t.item_path, t.id, t.rundir, t.final_logf FROM runs as r INNER JOIN tests AS t ON t.run_id=r.id + WHERE t.state='COMPLETED' AND r.target like ? AND r.run_name like ?;" targets run-patt) +) + +(define (pgdb:get-test-by-id dbh id) + (dbi:get-rows dbh "SELECT t.test_name, t.item_path, t.rundir, t.final_logf FROM runs as r INNER JOIN tests AS t ON t.run_id=r.id + WHERE t.id = ?;" id) +) + +;;====================================================================== +;; V A R I O U S D A T A M A S S A G E R O U T I N E S +;;====================================================================== + +;; probably want to move these to a different model file + +;; create a hash of hashes with keys extracted from all-parts +;; using row-or-col to choose row or column +;; ht{row key}=>ht{col key}=>data +;; +;; fnum is the field number in the tuples to be split +;; + +(define (pgdb:mk-pattern dot type bp rel) + (let* ((typ (if (equal? type "all") + "%" + type)) + (dotprocess (if (equal? dot "all") + "%" + dot)) + (rel-num (if (equal? rel "") + "%" + rel)) + (pattern (conc "%/" bp "/" dotprocess "/" typ "_" rel-num))) +pattern)) + +(define (pgdb:coalesce-runs dbh runs all-parts row-or-col fnum) + (let* ((data (make-hash-table))) + + (for-each + (lambda (run) + (let* ((target (vector-ref run fnum)) + (parts (string-split target "/")) + (first (car parts)) + (rest (string-intersperse (cdr parts) "/")) + (coldat (hash-table-ref/default data first #f))) + (if (not coldat)(let ((newht (make-hash-table))) + (hash-table-set! data first newht) + (set! coldat newht))) + (hash-table-set! coldat rest run))) + runs) + data)) + + +(define (pgdb:coalesce-runs1 runs ) + (let* ((data (make-hash-table))) + + (for-each + (lambda (run) + (let* ((target (vector-ref run 0)) + (parts (string-split target "/")) + (first (car parts)) + (rest (string-intersperse (cdr parts) "/")) + (coldat (hash-table-ref/default data first #f))) + (if (not coldat)(let ((newht (make-hash-table))) + (hash-table-set! data first newht) + (set! coldat newht))) + (hash-table-set! coldat rest run))) + runs) + data)) + +;; given ordered data hash return a-keys +;; +(define (pgdb:ordered-data->a-keys ordered-data) + (sort (hash-table-keys ordered-data) string>=?)) + +;; given ordered data hash return b-keys +;; +(define (pgdb:ordered-data->b-keys ordered-data a-keys) + (delete-duplicates + (sort (apply + append + (map (lambda (sub-key) + (let ((subdat (hash-table-ref ordered-data sub-key))) + (hash-table-keys subdat))) + a-keys)) + string>=?))) + +;; given ordered data hash return a-keys +;; +(define (pgdb:ordered-data->a-keys ordered-data) + (sort (hash-table-keys ordered-data) string>=?)) + +;; given ordered data hash return b-keys +;; +(define (pgdb:ordered-data->b-keys ordered-data a-keys) + (delete-duplicates + (sort (apply + append + (map (lambda (sub-key) + (let ((subdat (hash-table-ref ordered-data sub-key))) + (hash-table-keys subdat))) + a-keys)) + string>=?))) + +(define (pgdb:coalesce-runs-by-slice runs slice) + (let* ((data (make-hash-table))) + (for-each + (lambda (run) + (let* ((target (vector-ref run 0)) + (run-name (vector-ref run 1)) + (parts (string-split target "/")) + (first (car parts)) + (rest (string-intersperse (cdr parts) "/")) + (coldat (hash-table-ref/default data rest #f))) + (if (not coldat)(let ((newht (make-hash-table))) + (hash-table-set! data rest newht) + (set! coldat newht))) + (hash-table-set! coldat run-name run))) + runs) + data)) + + +(define (pgdb:runs-to-hash runs ) + (let* ((data (make-hash-table))) + (for-each + (lambda (run) + (let* ((run-name (vector-ref run 0)) + (test (conc (vector-ref run 1) ":" (vector-ref run 3))) + (coldat (hash-table-ref/default data run-name #f))) + (if (not coldat)(let ((newht (make-hash-table))) + (hash-table-set! data run-name newht) + (set! coldat newht))) + (hash-table-set! coldat test run))) + runs) + data)) + +(define (pgdb:get-history-hash runs) + (let* ((data (make-hash-table))) + (for-each + (lambda (run) + (let* ((run-name (vector-ref run 0))) + (hash-table-set! data run-name run))) + runs) + data)) + +(define (pgdb:get-pg-lst tab2-pages) + (let loop ((i 1) + (lst `())) + (cond + ((> i tab2-pages ) + lst) + (else + (loop (+ i 1) (append lst (list i))))))) + ADDED chicken.makefile Index: chicken.makefile ================================================================== --- /dev/null +++ chicken.makefile @@ -0,0 +1,179 @@ + +# Copyright 2006-2017, Matthew Welland. +# +# This file is part of Megatest. +# +# Megatest is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# Megatest is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with Megatest. If not, see . + + +#====================================================================== +# Chicken build +#====================================================================== + +# CHICKEN_BIN_DIR=$(shell dirname $(shell which csi)) +# if have csi on path use that, else use default +# CSIPATH=$(shell which csi) +# CKPATH=$(shell dirname $(shell dirname $(CSIPATH))) +CHICKEN_PREFIX=$(or $(CKPATH),$(PREFIX)/bin/.$(ARCHSTR)) + +whatever : + @echo "CHICKEN_PREFIX=$(CHICKEN_PREFIX)" + +tgz-$(USER)/postgresql-9.6.4.tar.gz : + mkdir -p tgz-$(USER) + wget -c https://ftp.postgresql.org/pub/source/v9.6.4/postgresql-9.6.4.tar.gz + mv postgresql-9.6.4.tar.gz tgz-$(USER)/ + +tgz-$(USER)/sqlite-autoconf-3090200.tar.gz : + mkdir -p tgz-$(USER) + curl http://www.sqlite.org/2015/sqlite-autoconf-3090200.tar.gz > tgz-$(USER)/sqlite-autoconf-3090200.tar.gz + +tgz-$(USER)/nanomsg-1.0.0.tar.gz : + wget --no-check-certificate https://github.com/nanomsg/nanomsg/archive/1.0.0.tar.gz + mv 1.0.0.tar.gz tgz-$(USER)/nanomsg-1.0.0.tar.gz + +tgz-$(USER)/chicken-4.13.0.tar.gz : + mkdir -p tgz-$(USER) + curl https://code.call-cc.org/releases/4.13.0/chicken-4.13.0.tar.gz > tgz-$(USER)/chicken-4.13.0.tar.gz + +tgz-$(USER)/ffcall.tar.gz : + wget -c -O tgz-$(USER)/ffcall.tar.gz 'http://www.kiatoa.com/fossils/ffcall/tarball?name=ffcall&uuid=trunk' + +$(CHICKEN_PREFIX)/bin/pg_config : tgz-$(USER)/postgresql-9.6.4.tar.gz + mkdir -p build-$(USER)/ + tar xfz tgz-$(USER)/postgresql-9.6.4.tar.gz -C build-$(USER) + cd build-$(USER)/postgresql-9.6.4; ./configure --prefix=$(CHICKEN_PREFIX) --with-openssl; make; make install + +build-$(USER)/sqlite-autoconf-3090200/configure : tgz-$(USER)/sqlite-autoconf-3090200.tar.gz + mkdir -p build-$(USER); + cd build-$(USER); tar xf ../tgz-$(USER)/sqlite-autoconf-3090200.tar.gz + +$(CHICKEN_PREFIX)/lib/libnanomsg.so : tgz-$(USER)/nanomsg-1.0.0.tar.gz + cd tgz-$(USER); tar -xzvf nanomsg-1.0.0.tar.gz + cd tgz-$(USER)/nanomsg-1.0.0; mkdir build-$(USER); cd build-$(USER); + cd tgz-$(USER)/nanomsg-1.0.0/build-$(USER); cmake ../ -DCMAKE_INSTALL_PREFIX=$(CHICKEN_PREFIX) + cd tgz-$(USER)/nanomsg-1.0.0/build-$(USER); make; make install + +$(CHICKEN_PREFIX)/chicken-4.13.0/LICENSE : tgz-$(USER)/chicken-4.13.0.tar.gz + mkdir -p build-$(USER)/eggs-installed + cd build-$(USER);tar xf ../tgz-$(USER)/chicken-4.13.0.tar.gz + if [[ -e $(CHICKEN_PREFIX)/chicken-4.13.0/LICENSE ]];then touch $(CHICKEN_PREFIX)/chicken-4.13.0/LICENSE;fi + +tgz-$(USER)/opensrc.fossil : + cd tgz-$(USER); fossil clone http://www.kiatoa.com/fossils/opensrc opensrc.fossil + mkdir tgz-$(USER)/opensrc + cd tgz-$(USER)/opensrc; fossil open --nested ../opensrc.fossil; fossil up; fossil uv sync + +$(CHICKEN_PREFIX)/lib/libiupweb.so : tgz-$(USER)/opensrc.fossil + cd tgz-$(USER)/opensrc; fossil unversioned cat libs/cd/cd-5.10_Linux26g4_64_lib.tar.gz > ../cd.tgz + cd tgz-$(USER)/opensrc; fossil unversioned cat libs/im/im-3.11_Linux26g4_64_lib.tar.gz > ../im.tgz + cd tgz-$(USER)/opensrc; fossil unversioned cat libs/iup/iup-3.19.1_Linux26g4_64_lib.tar.gz > ../iup.tgz + cd tgz-$(USER); tar -xzf cd.tgz; + cd tgz-$(USER); tar -xzf im.tgz; + cd tgz-$(USER); tar -xzf iup.tgz; + cp tgz-$(USER)/include/* $(CHICKEN_PREFIX)/include/ + cp tgz-$(USER)/*.so $(CHICKEN_PREFIX)/lib/ + cp tgz-$(USER)/*.a $(CHICKEN_PREFIX)/lib/ + cp tgz-$(USER)/ftgl/lib/*/* $(CHICKEN_PREFIX)/lib/ + +EGGS=srfi-69 srfi-42 sqlite3 iup canvas-draw typed-records md5 regex-case base64 \ +format dot-locking csv-xml z3 udp hostinfo directory-utils stack dbi crypt sha1 \ +posix-extras pathname-expand csv call-with-environment-variables s11n spiffy \ +uri-common intarweb http-client spiffy-request-vars spiffy-directory-listing \ +ansi-escape-sequences test slice rfc3339 uuid-lib filepath srfi-19 sparse-vectors \ +sql-de-lite fmt readline apropos json simple-exceptions rpc trace logpro refdb postgresql nanomsg +EGGSTARG=$(addsuffix .done,$(addprefix build-$(USER)/eggs-installed/,$(EGGS))) +EGGSTARG2=$(addsuffix .done, $(EGGS)) + +$(CHICKEN_PREFIX)/lib/libcallback.a : tgz-$(USER)/ffcall.tar.gz + cd tgz-$(USER); tar -xzvf ffcall.tar.gz + cd tgz-$(USER)/ffcall; ./configure --prefix=$(CHICKEN_PREFIX) --enable-shared + cd tgz-$(USER)/ffcall; make CC="gcc -fPIC"; make install + +$(CHICKEN_PREFIX)/bin/sqlite3 : build-$(USER)/sqlite-autoconf-3090200/configure + cd build-$(USER)/sqlite-autoconf-3090200; ./configure --prefix=$(CHICKEN_PREFIX); make; make install + +$(CHICKEN_PREFIX)/bin/csi : $(SQLITE3_DEP) $(CHICKEN_PREFIX)/lib/libiupweb.so $(CHICKEN_PREFIX)/chicken-4.13.0/LICENSE + cd build-$(USER)/chicken-4.13.0;make PLATFORM=linux PREFIX=$(CHICKEN_PREFIX) + cd build-$(USER)/chicken-4.13.0;make PLATFORM=linux PREFIX=$(CHICKEN_PREFIX) install + +ALL_CKBIN=chicken chicken-bind chicken-bug chicken-dump \ +chicken-install chicken-profile chicken-sqlite3 chicken-status \ +chicken-uninstall csc csi feathers nanocat sqlite3 vacuumdb logpro \ +refdb + +CKBIN_WRAPPERS=$(addprefix $(PREFIX)/bin/,$(ALL_CKBIN)) + +$(PREFIX)/bin/% : $(CHICKEN_PREFIX)/bin/% $(CHICKEN_PREFIX)/bin/csi + utils/mk_wrapper_tool $(PREFIX) $* $(PREFIX)/bin/$* + chmod a+x $(PREFIX)/bin/$* + +$(PREFIX)/bin : + mkdir -p $(PREFIX)/bin $(CHICKEN_PREFIX)/bin + +# For the future - binwrappers +chicken : $(PREFIX)/bin $(CHICKEN_PREFIX)/bin/csi postgresql.done nanomsg.done iup.done canvas-draw.done sqlite3.done sql-de-lite.done dbi.done $(EGGSTARG2) + @echo "Fake target to build prefix chicken" + +binwrappers : $(CKBIN_WRAPPERS) + +# make the dep a dummy if not requiring our own build of postgres +ifeq ($(BUILD_POSTGRES),yes) +PG_DEP=$(CHICKEN_PREFIX)/bin/pg_config +else +PG_DEP=$(CHICKEN_PREFIX)/bin/csi +endif + +postgresql.done : $(PG_DEP) + CSC_OPTIONS="-I$(CHICKEN_PREFIX)/include -L$(CHICKEN_PREFIX)/lib -L$(CHICKEN_PREFIX)/lib64" $(CHICKEN_PREFIX)/bin/chicken-install postgresql > postgresql.done + +ifeq ($(BUILD_NANOMSG),yes) +NMSG_DEP=$(CHICKEN_PREFIX)/lib/libnanomsg.so +else +NMSG_DEP=$(CHICKEN_PREFIX)/bin/csi +endif + +nanomsg.done : $(NMSG_DEP) + CSC_OPTIONS="-I$(CHICKEN_PREFIX)/include -L$(CHICKEN_PREFIX)/lib -L$(CHICKEN_PREFIX)/lib64" $(CHICKEN_PREFIX)/bin/chicken-install nanomsg > nanomsg.done + +iup.done : $(CHICKEN_PREFIX)/lib/libcallback.a + CSC_OPTIONS="-I$(CHICKEN_PREFIX)/include -L$(CHICKEN_PREFIX)/lib" $(CHICKEN_PREFIX)/bin/chicken-install -D no-library-checks -feature disable-iup-web -feature disable-iup-pplot -feature disable-iup-matrixex iup > iup.done + +canvas-draw.done : + CSC_OPTIONS="-I$(CHICKEN_PREFIX)/include -L$(CHICKEN_PREFIX)/lib" $(CHICKEN_PREFIX)/bin/chicken-install -D no-library-checks canvas-draw > canvas-draw.done + +# make the dep a dummy if not requiring our own build of postgres +ifeq ($(BUILD_SQLITE3),yes) +SQLITE3_DEP=$(CHICKEN_PREFIX)/bin/sqlite3 +else +SQLITE3_DEP=$(CHICKEN_PREFIX)/bin/csi +endif + +sqlite3.done : $(SQLITE3_DEP) + CSC_OPTIONS="-I$(CHICKEN_PREFIX)/include -L$(CHICKEN_PREFIX)/lib" $(CHICKEN_PREFIX)/bin/chicken-install sqlite3 > sqlite3.done + +sql-de-lite.done : + CSC_OPTIONS="-I$(CHICKEN_PREFIX)/include -L$(CHICKEN_PREFIX)/lib" $(CHICKEN_PREFIX)/bin/chicken-install sql-de-lite > sql-de-lite.done + +dbi.done : postgresql.done sqlite3.done sql-de-lite.done + CSC_OPTIONS="-I$(CHICKEN_PREFIX)/include -L$(CHICKEN_PREFIX)/lib" $(CHICKEN_PREFIX)/bin/chicken-install dbi > dbi.done + +%.done : + $(CHICKEN_PREFIX)/bin/chicken-install $* > $*.done + +build-$(USER)/eggs-installed/%.done : $(CHICKEN_PREFIX)/bin/csi $(EGGS) + $(CHICKEN_PREFIX)/bin/chicken-install $* > build-$(USER)/eggs-installed/$*.done + +build-clean : + rm -rf build-$(USER) bin Index: client.scm ================================================================== --- client.scm +++ client.scm @@ -1,27 +1,30 @@ ;; Copyright 2006-2012, Matthew Welland. ;; -;; This program is made available under the GNU GPL version 2.0 or -;; greater. See the accompanying file COPYING for details. +;; This file is part of Megatest. +;; +;; Megatest is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. +;; +;; Megatest is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. ;; -;; This program is distributed WITHOUT ANY WARRANTY; without even the -;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR -;; PURPOSE. +;; You should have received a copy of the GNU General Public License +;; along with Megatest. If not, see . ;;====================================================================== ;; C L I E N T S ;;====================================================================== -(require-extension (srfi 18) extras tcp s11n) - -(use sqlite3 srfi-1 posix regex regex-case srfi-69 hostinfo md5 message-digest) -;; (use zmq) - -(import (prefix sqlite3 sqlite3:)) - -(use spiffy uri-common intarweb http-client spiffy-request-vars uri-common intarweb directory-utils) +(use srfi-18 extras tcp s11n srfi-1 posix regex srfi-69 hostinfo md5 + message-digest matchable spiffy uri-common intarweb http-client + spiffy-request-vars uri-common intarweb directory-utils) (declare (unit client)) (declare (uses common)) (declare (uses db)) @@ -36,113 +39,29 @@ (let ((sig (conc (get-host-name) " " (current-process-id)))) (set! *my-client-signature* sig) *my-client-signature*))) ;; Not currently used! But, I think it *should* be used!!! -(define (client:logout serverdat) +#;(define (client:logout serverdat) (let ((ok (and (socket? serverdat) (cdb:logout serverdat *toppath* (client:get-signature))))) ok)) -(define (client:connect iface port) - (case (server:get-transport) +#;(define (client:connect iface port) + (http-transport:client-connect iface port) + #;(case (server:get-transport) ((rpc) (rpc:client-connect iface port)) ((http) (http:client-connect iface port)) ((zmq) (zmq:client-connect iface port)) (else (rpc:client-connect iface port)))) -(define (client:setup run-id #!key (remaining-tries 10) (failed-connects 0)) - (case (server:get-transport) - ((rpc) (rpc-transport:client-setup run-id)) ;;(client:setup-rpc run-id)) - ((http)(client:setup-http run-id)) - (else (rpc-transport:client-setup run-id)))) ;; (client:setup-rpc run-id)))) - -;; (define (client:login-no-auto-setup server-info run-id) -;; (case (server:get-transport) -;; ((rpc) (rpc:login-no-auto-client-setup server-info run-id)) -;; ((http) (rmt:login-no-auto-client-setup server-info run-id)) -;; (else (rpc:login-no-auto-client-setup server-info run-id)))) -;; -;; (define (client:setup-rpc run-id) -;; (debug:print 0 *default-log-port* "INFO: client:setup remaining-tries=" remaining-tries) -;; (if (<= remaining-tries 0) -;; (begin -;; (debug:print-error 0 *default-log-port* "failed to start or connect to server for run-id " run-id) -;; (exit 1)) -;; (let ((host-info (hash-table-ref/default *runremote* run-id #f))) -;; (debug:print-info 0 *default-log-port* "client:setup host-info=" host-info ", remaining-tries=" remaining-tries) -;; (if host-info -;; (let* ((iface (car host-info)) -;; (port (cadr host-info)) -;; (start-res (client:connect iface port)) -;; ;; (ping-res (server:ping-server run-id iface port)) -;; (ping-res (client:login-no-auto-setup start-res run-id))) -;; (if ping-res ;; sucessful login? -;; (begin -;; (hash-table-set! *runremote* run-id start-res) -;; start-res) ;; return the server info -;; (if (member remaining-tries '(3 4 6)) -;; (begin ;; login failed -;; (debug:print 25 *default-log-port* "INFO: client:setup start-res=" start-res ", run-id=" run-id ", server-dat=" host-info) -;; (hash-table-delete! *runremote* run-id) -;; (open-run-close tasks:server-force-clean-run-record -;; tasks:open-db -;; run-id -;; (car host-info) -;; (cadr host-info) -;; " client:setup (host-info=#t)") -;; (thread-sleep! 5) -;; (client:setup run-id remaining-tries: 10)) ;; (- remaining-tries 1))) -;; (begin -;; (debug:print 25 *default-log-port* "INFO: client:setup failed to connect, start-res=" start-res ", run-id=" run-id ", host-info=" host-info) -;; (thread-sleep! 5) -;; (client:setup run-id remaining-tries: (- remaining-tries 1)))))) -;; ;; YUK: rename server-dat here -;; (let* ((server-dat (open-run-close tasks:get-server tasks:open-db run-id))) -;; (debug:print-info 0 *default-log-port* "client:setup server-dat=" server-dat ", remaining-tries=" remaining-tries) -;; (if server-dat -;; (let* ((iface (tasks:hostinfo-get-interface server-dat)) -;; (port (tasks:hostinfo-get-port server-dat)) -;; (start-res (http-transport:client-connect iface port)) -;; ;; (ping-res (server:ping-server run-id iface port)) -;; (ping-res (rmt:login-no-auto-client-setup start-res run-id))) -;; (if start-res -;; (begin -;; (hash-table-set! *runremote* run-id start-res) -;; start-res) -;; (if (member remaining-tries '(2 5)) -;; (begin ;; login failed -;; (debug:print 25 *default-log-port* "INFO: client:setup start-res=" start-res ", run-id=" run-id ", server-dat=" server-dat) -;; (hash-table-delete! *runremote* run-id) -;; (open-run-close tasks:server-force-clean-run-record -;; tasks:open-db -;; run-id -;; (tasks:hostinfo-get-interface server-dat) -;; (tasks:hostinfo-get-port server-dat) -;; " client:setup (server-dat = #t)") -;; (thread-sleep! 2) -;; (server:try-running run-id) -;; (thread-sleep! 10) ;; give server a little time to start up -;; (client:setup run-id remaining-tries: 10)) ;; (- remaining-tries 1))) -;; (begin -;; (debug:print 25 *default-log-port* "INFO: client:setup start-res=" start-res ", run-id=" run-id ", server-dat=" server-dat) -;; (thread-sleep! 5) -;; (client:setup run-id remaining-tries: (- remaining-tries 1)))))) -;; (begin ;; no server registered -;; (if (eq? remaining-tries 2) -;; (begin -;; ;; (open-run-close tasks:server-clean-out-old-records-for-run-id tasks:open-db run-id " client:setup (server-dat=#f)") -;; (client:setup run-id remaining-tries: 10)) -;; (begin -;; (thread-sleep! 2) -;; (debug:print 25 *default-log-port* "INFO: client:setup start-res (not defined here), run-id=" run-id ", server-dat=" server-dat) -;; (if (< (open-run-close tasks:num-in-available-state tasks:open-db run-id) 3) -;; (begin -;; ;; (open-run-close tasks:server-clean-out-old-records-for-run-id tasks:open-db run-id " client:setup (server-dat=#f)") -;; (server:try-running run-id))) -;; (thread-sleep! 10) ;; give server a little time to start up -;; (client:setup run-id remaining-tries: (- remaining-tries 1))))))))))) +(define (client:setup areapath #!key (remaining-tries 100) (failed-connects 0)) + (client:setup-http areapath remaining-tries: remaining-tries failed-connects: failed-connects) + #;(case (server:get-transport) + ((rpc) (rpc-transport:client-setup remaining-tries: remaining-tries failed-connects: failed-connects)) ;;(client:setup-rpc run-id)) + ((http)(client:setup-http areapath remaining-tries: remaining-tries failed-connects: failed-connects)) + (else (rpc-transport:client-setup remaining-tries: remaining-tries failed-connects: failed-connects)))) ;; (client:setup-rpc run-id)))) ;; Do all the connection work, look up the transport type and set up the ;; connection if required. ;; ;; There are two scenarios. @@ -152,97 +71,53 @@ ;; ;; client:setup ;; ;; lookup_server, need to remove *runremote* stuff ;; -(define (client:setup-http run-id #!key (remaining-tries 10) (failed-connects 0)) + +(define (client:setup-http areapath #!key (remaining-tries 100) (failed-connects 0)(area-dat #f)) (debug:print-info 2 *default-log-port* "client:setup remaining-tries=" remaining-tries) - (let* ((tdbdat (tasks:open-db))) - (if (<= remaining-tries 0) - (begin - (debug:print-error 0 *default-log-port* "failed to start or connect to server for run-id " run-id) - (exit 1)) - (let* ((server-dat (tasks:get-server (db:delay-if-busy tdbdat) run-id))) - (debug:print-info 4 *default-log-port* "client:setup server-dat=" server-dat ", remaining-tries=" remaining-tries) - (if server-dat - (let* ((iface (tasks:hostinfo-get-interface server-dat)) - (hostname (tasks:hostinfo-get-hostname server-dat)) - (port (tasks:hostinfo-get-port server-dat)) - (start-res (case *transport-type* - ((http)(http-transport:client-connect iface port)) - ((nmsg)(nmsg-transport:client-connect hostname port)))) - (ping-res (case *transport-type* - ((http)(rmt:login-no-auto-client-setup start-res run-id)) - ((nmsg)(let ((logininfo (rmt:login-no-auto-client-setup start-res run-id))) - (if logininfo - (car (vector-ref logininfo 1)) - #f)))))) - (if (and start-res - ping-res) - (begin - (hash-table-set! *runremote* run-id start-res) - (debug:print-info 2 *default-log-port* "connected to " (http-transport:server-dat-make-url start-res)) - start-res) - (begin ;; login failed but have a server record, clean out the record and try again - (debug:print-info 0 *default-log-port* "client:setup, login failed, will attempt to start server ... start-res=" start-res ", run-id=" run-id ", server-dat=" server-dat) - (case *transport-type* - ((http)(http-transport:close-connections run-id))) - (hash-table-delete! *runremote* run-id) - (tasks:kill-server-run-id run-id) - (tasks:server-force-clean-run-record (db:delay-if-busy tdbdat) - run-id - (tasks:hostinfo-get-interface server-dat) - (tasks:hostinfo-get-port server-dat) - " client:setup (server-dat = #t)") - (if (> remaining-tries 8) - (thread-sleep! (+ 1 (random 5))) ;; spread out the starts a little - (thread-sleep! (+ 15 (random 20)))) ;; it isn't going well. give it plenty of time - (server:try-running run-id) - (thread-sleep! 5) ;; give server a little time to start up - (client:setup run-id remaining-tries: (- remaining-tries 1)) - ))) - (begin ;; no server registered - (let ((num-available (tasks:num-in-available-state (db:dbdat-get-db tdbdat) run-id))) - (debug:print-info 0 *default-log-port* "client:setup, no server registered, remaining-tries=" remaining-tries " num-available=" num-available) - (if (< num-available 2) - (server:try-running run-id)) - (thread-sleep! (+ 5 (random (- 20 remaining-tries)))) ;; give server a little time to start up, randomize a little to avoid start storms. - (client:setup run-id remaining-tries: (- remaining-tries 1))))))))) - -;; keep this as a function to ease future -(define (client:start run-id server-info) - (http-transport:client-connect (tasks:hostinfo-get-interface server-info) - (tasks:hostinfo-get-port server-info))) - -;; ;; client:signal-handler -;; (define (client:signal-handler signum) -;; (signal-mask! signum) -;; (set! *time-to-exit* #t) -;; (handle-exceptions -;; exn -;; (debug:print 0 *default-log-port* " ... exiting ...") -;; (let ((th1 (make-thread (lambda () -;; "") ;; do nothing for now (was flush out last call if applicable) -;; "eat response")) -;; (th2 (make-thread (lambda () -;; (debug:print-error 0 *default-log-port* "Received ^C, attempting clean exit. Please be patient and wait a few seconds before hitting ^C again.") -;; (thread-sleep! 1) ;; give the flush one second to do it's stuff -;; (debug:print 0 *default-log-port* " Done.") -;; (exit 4)) -;; "exit on ^C timer"))) -;; (thread-start! th2) -;; (thread-start! th1) -;; (thread-join! th2)))) -;; -;; ;; client:launch -;; ;; Need to set the signal handler somewhere other than here as this -;; ;; routine will go away. -;; ;; -;; (define (client:launch run-id) -;; (set-signal-handler! signal/int client:signal-handler) -;; (set-signal-handler! signal/term client:signal-handler) -;; (if (client:setup run-id) -;; (debug:print-info 2 *default-log-port* "connected as client") -;; (begin -;; (debug:print-error 0 *default-log-port* "Failed to connect as client") -;; (exit)))) -;; + (server:start-and-wait areapath) + (if (<= remaining-tries 0) + (begin + (debug:print-error 0 *default-log-port* "failed to start or connect to server") + (exit 1)) + ;; + ;; Alternatively here, we can get the list of candidate servers and work our way + ;; through them searching for a good one. + ;; + (let* ((server-dat (server:get-rand-best areapath)) ;; (server:get-first-best areapath)) + (runremote (or area-dat *runremote*))) + (if (not server-dat) ;; no server found + (client:setup-http areapath remaining-tries: (- remaining-tries 1)) + (let ((host (cadr server-dat)) + (port (caddr server-dat))) + (debug:print-info 4 *default-log-port* "client:setup server-dat=" server-dat ", remaining-tries=" remaining-tries) + (if (and (not area-dat) + (not *runremote*)) + (set! *runremote* (make-remote))) + (if (and host port) + (let* ((start-res (case *transport-type* + ((http)(http-transport:client-connect host port)))) + (ping-res (case *transport-type* + ((http)(rmt:login-no-auto-client-setup start-res))))) + (if (and start-res + ping-res) + (let ((runremote (or area-dat *runremote*))) ;; it might have been generated only a few statements ago + (remote-conndat-set! runremote start-res) ;; (hash-table-set! runremote run-id start-res) + (debug:print-info 2 *default-log-port* "connected to " (http-transport:server-dat-make-url start-res)) + start-res) + (begin ;; login failed but have a server record, clean out the record and try again + (debug:print-info 0 *default-log-port* "client:setup, login unsuccessful, will attempt to start server ... start-res=" start-res ", server-dat=" server-dat) ;; had runid. Fixes part of Randy;s ticket 1405717332 + (case *transport-type* + ((http)(http-transport:close-connections))) + (remote-conndat-set! runremote #f) ;; (hash-table-delete! runremote run-id) + (thread-sleep! 1) + (client:setup-http areapath remaining-tries: (- remaining-tries 1)) + ))) + (begin ;; no server registered + ;; (server:kind-run areapath) + (server:start-and-wait areapath) + (debug:print-info 0 *default-log-port* "client:setup, no server registered, remaining-tries=" remaining-tries) + (thread-sleep! 1) ;; (+ 5 (random (- 20 remaining-tries)))) ;; give server a little time to start up, randomize a little to avoid start storms. + (client:setup-http areapath remaining-tries: (- remaining-tries 1))))))))) + ADDED codescanlib.scm Index: codescanlib.scm ================================================================== --- /dev/null +++ codescanlib.scm @@ -0,0 +1,144 @@ +;; Copyright 2006-2017, Matthew Welland. +;; +;; This file is part of Megatest. +;; +;; Megatest is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. +;; +;; Megatest is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with Megatest. If not, see . +;; + +;; gotta compile with csc, doesn't work with csi -s for whatever reason + +(use srfi-69) +(use matchable) +(use utils) +(use ports) +(use extras) +(use srfi-1) +(use posix) +(use srfi-12) + +;; turn scheme file to a list of sexps, sexps of interest will be in the form of (define ( ) ) +(define (load-scm-file scm-file) + ;;(print "load "scm-file) + (handle-exceptions + exn + '() + (with-input-from-string + (conc "(" + (with-input-from-file scm-file read-all) + ")" ) + read))) + +;; extract a list of procname, filename, args and body of procedures defined in filename, input from load-scm-file +;; -- be advised: +;; * this may be fooled by macros, since this code does not take them into account. +;; * this code does only checks for form (define ( ... ) ) +;; so it excludes from reckoning +;; - generated functions, as in things like foo-set! from defstructs, +;; - define-inline, ( +;; - define procname (lambda .. +;; - etc... +(define (get-toplevel-procs+file+args+body filename) + (let* ((scm-tree (load-scm-file filename)) + (procs + (filter identity + (map + (match-lambda + [('define ('uses args ...) body ...) #f] ;; filter out (define (uses ... + [('define ('unit args ...) body ...) #f] ;; filter out (define (unit ... + [('define ('prefix args ...) body ...) #f] ;; filter out (define (prefix ... + [('define (defname args ...) body ...) ;; match (define (procname ) ) + (if (atom? defname) ;; filter out things we dont understand (procname is a list, what??) + (list defname filename args body) + #f)] + [else #f] ) scm-tree)))) + procs)) + + +;; given a sexp, return a flat list of atoms in that sexp +(define (get-atoms-in-body body) + (cond + ((null? body) '()) + ((atom? body) (list body)) + (else + (apply append (map get-atoms-in-body body))))) + +;; given a file, return a list of procname, file, list of atoms in said procname +(define (get-procs+file+atoms file) + (let* ((toplevel-proc-items (get-toplevel-procs+file+args+body file)) + (res + (map + (lambda (item) + (let* ((proc (car item)) + (file (cadr item)) + (args (caddr item)) + (body (cadddr item)) + (atoms (append (get-atoms-in-body args) (get-atoms-in-body body)))) + (list proc file atoms))) + toplevel-proc-items))) + res)) + +;; uniquify a list of atoms +(define (unique-atoms lst) + (let loop ((lst (flatten lst)) (res '())) + (if (null? lst) + (reverse res) + (let ((c (car lst))) + (loop (cdr lst) (if (member c res) res (cons c res))))))) + +;; given a list of procname, filename, list of procs called from procname, cross reference and reverse +;; returning alist mapping procname to procname that calls said procname +(define (get-callers-alist all-procs+file+calls) + (let* ((all-procs (map car all-procs+file+calls)) + (caller-ht (make-hash-table))) + ;; let's cross reference with a hash table + (for-each (lambda (proc) (hash-table-set! caller-ht proc '())) all-procs) + (for-each (lambda (item) + (let* ((proc (car item)) + (file (cadr item)) + (calls (caddr item))) + (for-each (lambda (callee) + (hash-table-set! caller-ht callee + (cons proc + (hash-table-ref caller-ht callee)))) + calls))) + all-procs+file+calls) + (map (lambda (x) + (let ((k (car x)) + (r (unique-atoms (cdr x)))) + (cons k r))) + (hash-table->alist caller-ht)))) + +;; create a handy cross-reference of callees to callers in the form of an alist. +(define (get-xref all-scm-files) + (let* ((all-procs+file+atoms + (apply append (map get-procs+file+atoms all-scm-files))) + (all-procs (map car all-procs+file+atoms)) + (all-procs+file+calls ; proc calls things in calls list + (map (lambda (item) + (let* ((proc (car item)) + (file (cadr item)) + (atoms (caddr item)) + (calls + (filter identity + (map + (lambda (x) + (if (and ;; (not (equal? x proc)) ;; uncomment to prevent listing self + (member x all-procs)) + x + #f)) + atoms)))) + (list proc file calls))) + all-procs+file+atoms)) + (callers (get-callers-alist all-procs+file+calls))) + callers)) Index: common.scm ================================================================== --- common.scm +++ common.scm @@ -1,27 +1,40 @@ ;;====================================================================== ;; Copyright 2006-2012, Matthew Welland. ;; -;; This program is made available under the GNU GPL version 2.0 or -;; greater. See the accompanying file COPYING for details. +;; This file is part of Megatest. +;; +;; Megatest is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. +;; +;; Megatest is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. ;; -;; This program is distributed WITHOUT ANY WARRANTY; without even the -;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR -;; PURPOSE. +;; You should have received a copy of the GNU General Public License +;; along with Megatest. If not, see . + ;;====================================================================== -(use srfi-1 posix regex-case base64 format dot-locking csv-xml z3 nanomsg sql-de-lite hostinfo) -(require-extension regex posix) - -(require-extension (srfi 18) extras tcp rpc) - -(import (prefix sqlite3 sqlite3:)) -(import (prefix base64 base64:)) +(use srfi-1 data-structures posix regex-case (prefix base64 base64:) + format dot-locking csv-xml z3 udp ;; sql-de-lite + hostinfo md5 message-digest typed-records directory-utils stack + matchable regex posix (srfi 18) extras ;; tcp + (prefix nanomsg nmsg:) + (prefix sqlite3 sqlite3:) + pkts (prefix dbi dbi:) + ) (declare (unit common)) +;; (declare (uses commonmod)) +;; (import commonmod) (include "common_records.scm") + ;; (require-library margs) ;; (include "margs.scm") ;; (define old-exit exit) @@ -29,95 +42,297 @@ ;; (define (exit . code) ;; (if (null? code) ;; (old-exit) ;; (old-exit code))) + +;; execute thunk, return value. If exception thrown, trap exception, return #f, and emit nonfatal condition note to *default-log-port* . +;; arguments - thunk, message +(define (common:fail-safe thunk warning-message-on-exception) + (handle-exceptions + exn + (begin + (debug:print-info 0 *default-log-port* "notable but nonfatal condition - "warning-message-on-exception", exn=" exn) + (debug:print-info 0 *default-log-port* + (string-substitute "\n?Error:" "nonfatal condition:" + (with-output-to-string + (lambda () + (print-error-message exn) )))) + (debug:print-info 0 *default-log-port* " -- continuing after nonfatal condition...") + #f) + (thunk))) + (define getenv get-environment-variable) (define (safe-setenv key val) - (if (and (string? val)(string? key)) - (handle-exceptions - exn - (debug:print-error 0 *default-log-port* "bad value for setenv, key=" key ", value=" val) - (setenv key val)) - (debug:print-error 0 *default-log-port* "bad value for setenv, key=" key ", value=" val))) + (if (or (substring-index "!" key) + (substring-index ":" key) ;; variables containing : are for internal use and cannot be environment variables. + (substring-index "." key)) ;; periods are not allowed in environment variables + (debug:print-error 4 *default-log-port* "skip setting internal use only variables containing \":\" or starting with \"!\"") + (if (and (string? val) + (string? key)) + (handle-exceptions + exn + (debug:print-error 0 *default-log-port* "bad value for setenv, key=" key ", value=" val ", exn=" exn) + (setenv key val)) + (debug:print-error 0 *default-log-port* "bad value for setenv, key=" key ", value=" val)))) (define home (getenv "HOME")) (define user (getenv "USER")) -;; GLOBAL GLETCHES + +;; returns list of fd count, socket count +(define (get-file-descriptor-count #!key (pid (current-process-id ))) + (list + (length (glob (conc "/proc/" pid "/fd/*"))) + (length (filter identity (map socket? (glob (conc "/proc/" pid "/fd/*"))))) + ) +) + + + +;; GLOBALS + +;; CONTEXTS +(defstruct cxt + (taskdb #f) + (cmutex (make-mutex))) +;; (define *contexts* (make-hash-table)) +;; (define *context-mutex* (make-mutex)) + +;; ;; safe method for accessing a context given a toppath +;; ;; +;; (define (common:with-cxt toppath proc) +;; (mutex-lock! *context-mutex*) +;; (let ((cxt (hash-table-ref/default *contexts* toppath #f))) +;; (if (not cxt) +;; (set! cxt (let ((x (make-cxt)))(hash-table-set! *contexts* toppath x) x))) +;; (let ((cxt-mutex (cxt-mutex cxt))) +;; (mutex-unlock! *context-mutex*) +;; (mutex-lock! cxt-mutex) +;; (let ((res (proc cxt))) +;; (mutex-unlock! cxt-mutex) +;; res)))) + +;; A hash table that can be accessed by #{scheme ...} calls in +;; config files. Allows communicating between confgs +;; +(define *user-hash-data* (make-hash-table)) + (define *db-keys* #f) +(define *pkts-info* (make-hash-table)) ;; store stuff like the last parent here (define *configinfo* #f) ;; raw results from setup, includes toppath and table from megatest.config (define *runconfigdat* #f) ;; run configs data (define *configdat* #f) ;; megatest.config data (define *configstatus* #f) ;; status of data; 'fulldata : all processing done, #f : no data yet, 'partialdata : partial read done (define *toppath* #f) (define *already-seen-runconfig-info* #f) -(define *waiting-queue* (make-hash-table)) (define *test-meta-updated* (make-hash-table)) (define *globalexitstatus* 0) ;; attempt to work around possible thread issues (define *passnum* 0) ;; when running track calls to run-tests or similar -(define *write-frequency* (make-hash-table)) ;; run-id => (vector (current-seconds) 0)) -(define *alt-log-file* #f) ;; used by -log +;; (define *alt-log-file* #f) ;; used by -log (define *common:denoise* (make-hash-table)) ;; for low noise printing (define *default-log-port* (current-error-port)) +(define *time-zero* (current-seconds)) ;; for the watchdog +(define *default-area-tag* "local") ;; DATABASE -(define *dbstruct-db* #f) +(define *dbstruct-db* #f) ;; used to cache the dbstruct in db:setup. Goal is to remove this. +;; db stats (define *db-stats* (make-hash-table)) ;; hash of vectors < count duration-total > (define *db-stats-mutex* (make-mutex)) -(define *db-sync-mutex* (make-mutex)) -(define *db-multi-sync-mutex* (make-mutex)) -(define *db-local-sync* (make-hash-table)) ;; used to record last touch of db -(define *megatest-db* #f) -(define *last-db-access* (current-seconds)) ;; update when db is accessed via server +;; db access +(define *db-last-access* (current-seconds)) ;; last db access, used in server (define *db-write-access* #t) -(define *inmemdb* #f) +;; db sync +(define *db-last-sync* 0) ;; last time the sync to megatest.db happened +(define *db-sync-in-progress* #f) ;; if there is a sync in progress do not try to start another +(define *db-multi-sync-mutex* (make-mutex)) ;; protect access to *db-sync-in-progress*, *db-last-sync* +;; task db (define *task-db* #f) ;; (vector db path-to-db) (define *db-access-allowed* #t) ;; flag to allow access (define *db-access-mutex* (make-mutex)) +(define *db-transaction-mutex* (make-mutex)) +(define *db-cache-path* #f) +(define *db-with-db-mutex* (make-mutex)) +(define *db-api-call-time* (make-hash-table)) ;; hash of command => (list of times) +;; no sync db +(define *no-sync-db* #f) ;; SERVER (define *my-client-signature* #f) -(define *transport-type* 'http) (define *transport-type* 'http) ;; override with [server] transport http|rpc|nmsg -(define *runremote* (make-hash-table)) ;; if set up for server communication this will hold -(define *max-cache-size* 0) +(define *runremote* #f) ;; if set up for server communication this will hold +;; (define *max-cache-size* 0) (define *logged-in-clients* (make-hash-table)) -(define *client-non-blocking-mode* #f) (define *server-id* #f) -(define *server-info* #f) +(define *server-info* #f) ;; good candidate for easily convert to non-global (define *time-to-exit* #f) -(define *received-response* #f) -(define *default-numtries* 10) (define *server-run* #t) (define *run-id* #f) (define *server-kind-run* (make-hash-table)) +(define *home-host* #f) +;; (define *total-non-write-delay* 0) +(define *heartbeat-mutex* (make-mutex)) +(define *api-process-request-count* 0) +(define *max-api-process-requests* 0) +(define *server-overloaded* #f) +;; client +(define *rmt-mutex* (make-mutex)) ;; remote access calls mutex + +;; RPC transport +(define *rpc:listener* #f) + +;; KEY info (define *target* (make-hash-table)) ;; cache the target here; target is keyval1/keyval2/.../keyvalN (define *keys* (make-hash-table)) ;; cache the keys here (define *keyvals* (make-hash-table)) (define *toptest-paths* (make-hash-table)) ;; cache toptest path settings here (define *test-paths* (make-hash-table)) ;; cache test-id to test run paths here (define *test-ids* (make-hash-table)) ;; cache run-id, testname, and item-path => test-id (define *test-info* (make-hash-table)) ;; cache the test info records, update the state, status, run_duration etc. from testdat.db -(define *run-info-cache* (make-hash-table)) ;; run info is stable, no need to reget +(define *run-info-cache* (make-hash-table)) ;; run info is stable, no need to reget +(define *launch-setup-mutex* (make-mutex)) ;; need to be able to call launch:setup often so mutex it and re-call the real deal only if *toppath* not set +(define *homehost-mutex* (make-mutex)) -;; Awful. Please FIXME +;; Miscellaneous +(define *triggers-mutex* (make-mutex)) ;; block overlapping processing of triggers + +(use posix-extras pathname-expand files) + +;; this plugs a hole in posix-extras in recent chicken versions > 4.9) +(let-values (( (chicken-release-number chicken-major-version) + (apply values + (map string->number + (take + (string-split (chicken-version) ".") + 2))))) + (let ((resolve-pathname-broken? + (or (> chicken-release-number 4) + (and (eq? 4 chicken-release-number) (> chicken-major-version 9))))) + (if resolve-pathname-broken? + (define ##sys#expand-home-path pathname-expand)))) + +(define (realpath x) (resolve-pathname (pathname-expand (or x "/dev/null")) )) + +(define (common:get-this-exe-fullpath #!key (argv (argv))) + (let* ((this-script + (cond + ((and (> (length argv) 2) + (string-match "^(.*/csi|csi)$" (car argv)) + (string-match "^-(s|ss|sx|script)$" (cadr argv))) + (caddr argv)) + (else (car argv)))) + (fullpath (realpath this-script))) + fullpath)) +(define *common:this-exe-fullpath* (common:get-this-exe-fullpath)) +(define *common:this-exe-dir* (pathname-directory *common:this-exe-fullpath*)) +(define *common:this-exe-name* (pathname-strip-directory *common:this-exe-fullpath*)) + +;; when called from a wrapper I need sometimes to find the calling +;; wrapper, this is for dashboard to find the correct megatest. +;; +(define (common:find-local-megatest #!optional (progname "megatest")) + (let ((res (filter file-exists? + (map (lambda (updir) + (let* ((lm (car (argv))) + (dir (pathname-directory lm)) + (exe (pathname-strip-directory lm))) + (conc (if dir (conc dir "/") "") + (case (string->symbol exe) + ((dboard) (conc updir progname)) + ((mtest) (conc updir progname)) + ((dashboard) progname) + (else exe))))) + '("../../" "../"))))) + (if (null? res) + (begin + (debug:print 0 *current-log-port* "Failed to find this executable! Using what can be found on the path") + progname) + (car res)))) + +(define *common:logpro-exit-code->status-sym-alist* + '( ( 0 . pass ) + ( 1 . fail ) + ( 2 . warn ) + ( 3 . check ) + ( 4 . waived ) + ( 5 . abort ) + ( 6 . skip ))) + +(define (common:logpro-exit-code->status-sym exit-code) + (or (alist-ref exit-code *common:logpro-exit-code->status-sym-alist*) 'fail)) + +(define (common:worse-status-sym ss1 ss2) + (let loop ((status-syms-remaining '(abort fail check skip warn waived pass))) + (cond + ((null? status-syms-remaining) + 'fail) + ((eq? (car status-syms-remaining) ss1) + ss1) + ((eq? (car status-syms-remaining) ss2) + ss2) + (else + (loop (cdr status-syms-remaining)))))) + +(define (common:steps-can-proceed-given-status-sym status-sym) + (if (member status-sym '(warn waived pass)) + #t + #f)) + +(define (status-sym->string status-sym) + (case status-sym + ((pass) "PASS") + ((fail) "FAIL") + ((warn) "WARN") + ((check) "CHECK") + ((waived) "WAIVED") + ((abort) "ABORT") + ((skip) "SKIP") + (else "FAIL"))) + +(define (common:logpro-exit-code->test-status exit-code) + (status-sym->string (common:logpro-exit-code->status-sym exit-code))) + +(defstruct remote + (hh-dat (common:get-homehost)) ;; homehost record ( addr . hhflag ) + (server-url (if *toppath* (server:check-if-running *toppath*))) ;; (server:check-if-running *toppath*) #f)) + (last-server-check 0) ;; last time we checked to see if the server was alive + (conndat #f) + (transport *transport-type*) + (server-timeout (server:expiration-timeout)) + (force-server #f) + (ro-mode #f) + (ro-mode-checked #f)) ;; flag that indicates we have checked for ro-mode + +;; launching and hosts +(defstruct host + (reachable #f) + (last-update 0) + (last-used 0) + (last-cpuload 1)) + +(define *host-loads* (make-hash-table)) + +;; cache environment vars for each run here (define *env-vars-by-run-id* (make-hash-table)) -(define *current-run-name* #f) ;; Testconfig and runconfig caches. -(define *testconfigs* (make-hash-table)) ;; test-name => testconfig -(define *runconfigs* (make-hash-table)) ;; target => runconfig +(define *testconfigs* (make-hash-table)) ;; test-name => testconfig +(define *runconfigs* (make-hash-table)) ;; target => runconfig ;; This is a cache of pre-reqs met, don't re-calc in cases where called with same params less than ;; five seconds ago (define *pre-reqs-met-cache* (make-hash-table)) +;; cache of verbosity given string +;; +(define *verbosity-cache* (make-hash-table)) + (define (common:clear-caches) (set! *target* (make-hash-table)) (set! *keys* (make-hash-table)) (set! *keyvals* (make-hash-table)) (set! *toptest-paths* (make-hash-table)) @@ -131,10 +346,12 @@ ;; Generic string database (define sdb:qry #f) ;; (make-sdb:qry)) ;; 'init #f) ;; Generic path database (define *fdb* #f) +(define *last-launch* (current-seconds)) ;; use for throttling the launch rate. Would be better to use the db and last time of a test in LAUNCHED state. + ;;====================================================================== ;; V E R S I O N ;;====================================================================== (define (common:get-full-version) @@ -143,56 +360,279 @@ (define (common:version-signature) (conc megatest-version "-" (substring megatest-fossil-hash 0 4))) ;; from metadat lookup MEGATEST_VERSION ;; -(define (common:get-last-run-version) +(define (common:get-last-run-version) ;; RADT => How does this work in send-receive function??; assume it is the value saved in some DB (rmt:get-var "MEGATEST_VERSION")) +(define (common:get-last-run-version-number) + (string->number + (substring (common:get-last-run-version) 0 6))) + (define (common:set-last-run-version) (rmt:set-var "MEGATEST_VERSION" (common:version-signature))) +;; postive number if megatest version > db version +;; negative number if megatest version < db version +(define (common:version-db-delta) + (- megatest-version (common:get-last-run-version-number))) + (define (common:version-changed?) (not (equal? (common:get-last-run-version) - (common:version-signature)))) + (common:version-signature)))) +(define (common:api-changed?) + (not (equal? (substring (->string megatest-version) 0 4) + (substring (conc (common:get-last-run-version)) 0 4)))) + + +(define (common:get-sync-lock-filepath) + (let* ((tmp-area (common:get-db-tmp-area)) + (lockfile (conc tmp-area "/megatest.db.sync-lock"))) + lockfile)) + ;; Move me elsewhere ... +;; RADT => Why do we meed the version check here, this is called only if version misma ;; -(define (common:cleanup-db) - (db:multi-db-sync - #f ;; do all run-ids +(define (common:cleanup-db dbstruct #!key (full #f)) + (apply db:multi-db-sync + dbstruct + 'schema ;; 'new2old 'killservers - 'dejunk - ;; 'adj-testids + 'adj-target ;; 'old2new - 'new2old) - (if (common:version-changed?) + 'new2old + ;; (if full + '(dejunk) + ;; '()) + ) + (if (common:api-changed?) (common:set-last-run-version))) +(define (common:snapshot-file filepath #!key (subdir ".") ) + (if (file-exists? filepath) + (let* ((age-sec (lambda (file) + (if (file-exists? file) + (- (current-seconds) (file-modification-time file)) + 1000000000))) ;; return really old value if file doesn't exist. we want to clobber it if old or not exist. + (ok-flag #t) + (age-mins (lambda (file) (/ (age-sec file) 60))) + (age-hrs (lambda (file) (/ (age-mins file) 60))) + (age-days (lambda (file) (/ (age-hrs file) 24))) + (age-wks (lambda (file) (/ (age-days file) 7))) + (docmd (lambda (cmd) + (cond + (ok-flag + (let ((res (system cmd))) + (cond + ((eq? 0 res) + #t) + (else + (set! ok-flag #f) + (debug:print 0 *default-log-port* "ERROR: ["(common:human-time)"] Command failed with exit code " + (if (< res 0) + res + (/ res 8)) " ["cmd"]" ) + #f)))) + (else + (debug:print 0 *default-log-port* "ERROR: ["(common:human-time)"] Not runnining command due to prior error. ["cmd"]") + #f)))) + (copy (lambda (src dest) (docmd (conc "/bin/cp '"src"' '"dest"'")))) + (copy+zip (lambda (src dest) (docmd (conc "gzip -c - < '"src"' > '"dest"'")))) + (fullpath (realpath filepath)) + (basedir (pathname-directory fullpath)) + (basefile (pathname-strip-directory fullpath)) + ;;(prevfile (conc filepath ".prev.gz")) + (minsfile (conc basedir "/" subdir "/" basefile ".mins.gz")) + (hrsfile (conc basedir "/" subdir "/" basefile ".hrs.gz")) + (daysfile (conc basedir "/" subdir "/" basefile ".days.gz")) + (wksfile (conc basedir "/" subdir "/" basefile ".weeks.gz"))) + + ;; create subdir it not exists + (if (not (directory-exists? (conc basedir "/" subdir))) + (docmd (conc "/bin/mkdir -p '"(conc basedir "/" subdir)"'"))) + + ;; copy&zip to .mins if not exists + (if (not (file-exists? minsfile)) + (copy+zip filepath minsfile)) + ;; copy .mins to .hrs if not exists + (if (not (file-exists? hrsfile)) + (copy minsfile hrsfile)) + ;; copy .hrs to .days if not exists + (if (not (file-exists? daysfile)) + (copy hrsfile daysfile)) + ;; copy .days to .weeks if not exists + (if (not (file-exists? wksfile)) + (copy daysfile wksfile)) + + + ;; if age(.mins.gz) >= 1h: + ;; copy .mins.gz .hrs.gz + ;; copy .mins.gz + (when (>= (age-mins minsfile) 1) + (copy minsfile hrsfile) + (copy+zip filepath minsfile)) + + ;; if age(.hrs.gz) >= 1d: + ;; copy .hrs.gz .days.gz + ;; copy .mins.gz .hrs.gz + (when (>= (age-days hrsfile) 1) + (copy hrsfile daysfile) + (copy minsfile hrsfile)) + + ;; if age(.days.gz) >= 1w: + ;; copy .days.gz .weeks.gz + ;; copy .hrs.gz .days.gz + (when (>= (age-wks daysfile) 1) + (copy daysfile wksfile) + (copy hrsfile daysfile)) + #t) + #f)) + +(define (common:safe-vector-ref vec indx default) + (if (vector? vec) + (handle-exceptions + exn + (begin + (debug:print-info 0 *default-log-port* "remote data issue: exn=" exn) + default) + (vector-ref vec indx)) + default)) + + +;; Rotate logs, logic: +;; if > 500k and older than 1 week: +;; remove previous compressed log and compress this log +;; WARNING: This proc operates assuming that it is in the directory above the +;; logs directory you wish to log-rotate. +;; +(define (common:rotate-logs) + (let* ((all-files (make-hash-table)) + (stats (make-hash-table)) + (inc-stat (lambda (key) + (hash-table-set! stats key (+ (hash-table-ref/default stats key 0) 1)))) + (max-allowed (string->number (or (configf:lookup *configdat* "setup" "max-logfiles") "300")))) ;; name -> age + (if (not (directory-exists? "logs"))(create-directory "logs")) + (directory-fold + (lambda (file rem) + (handle-exceptions + exn + (begin + (debug:print-info 2 *default-log-port* "unable to rotate log " file ", probably handled by another process, this is safe to ignore. exn=" exn) + (debug:print 2 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) + ;; (print-call-chain (current-error-port)) ;; + ) + (let* ((fullname (conc "logs/" file)) + (mod-time (file-modification-time fullname)) + (file-age (- (current-seconds) mod-time)) + (file-old (> file-age (* 48 60 60))) + (file-big (> (file-size fullname) 200000))) + (hash-table-set! all-files file mod-time) + (if (or (and (string-match "^.*.log" file) + file-old + file-big) + (and (string-match "^server-.*.log" file) + file-old)) + (let ((gzfile (conc fullname ".gz"))) + (if (common:file-exists? gzfile) + (begin + (debug:print-info 0 *default-log-port* "removing " gzfile) + (delete-file* gzfile) + (hash-table-delete! all-files gzfile) ;; needed? + )) + (debug:print-info 0 *default-log-port* "compressing " file) + (system (conc "gzip " fullname)) + (inc-stat "gzipped") + (hash-table-set! all-files (conc file ".gz") file-age) ;; add the .gz file and remove the base file + (hash-table-delete! all-files file) + ) + (if (and (> file-age (* (string->number (or (configf:lookup *configdat* "setup" "log-expire-days") "30")) 24 3600)) + (file-exists? fullname)) ;; just in case it was gzipped - will get it next time + (handle-exceptions + exn + #f + (if (directory? fullname) + (begin + (debug:print-info 0 *default-log-port* fullname " in logs directory is a directory! Cannot rotate it, it is best to not put subdirectories in the logs dir.") + (inc-stat "directories")) + (begin + (delete-file* fullname) + (inc-stat "deleted"))) + (hash-table-delete! all-files file))))))) + '() + "logs") + (for-each + (lambda (category) + (let ((quant (hash-table-ref/default stats category 0))) + (if (> quant 0) + (debug:print-info 0 *default-log-port* category " log files: " quant)))) + `("deleted" "gzipped" "directories")) + (let ((num-logs (hash-table-size all-files))) + (if (> num-logs max-allowed) ;; because NFS => don't let number of logs exceed 300 + (let ((files (take (sort (hash-table-keys all-files) + (lambda (a b) + (< (hash-table-ref all-files a)(hash-table-ref all-files b)))) + (- num-logs max-allowed)))) + (for-each + (lambda (file) + (let* ((fullname (conc "logs/" file))) + (if (directory? fullname) + (debug:print-info 0 *default-log-port* fullname " in logs directory is a directory! Cannot rotate it, it is best to not put subdirectories in the logs dir.") + (handle-exceptions + exn + (debug:print-error 0 *default-log-port* "failed to remove " fullname ", exn=" exn) + (delete-file* fullname))))) + files) + (debug:print-info 0 *default-log-port* "Deleted " (length files) " files from logs, keeping " max-allowed " files.")))))) + +;; Force a megatest cleanup-db if version is changed and skip-version-check not specified +;; Do NOT check if not on homehost! +;; (define (common:exit-on-version-changed) - (if (common:version-changed?) - (let ((mtconf (conc (get-environment-variable "MT_RUN_AREA_HOME") "/megatest.config"))) - (debug:print 0 *default-log-port* - "ERROR: Version mismatch!\n" - " expected: " (common:version-signature) "\n" - " got: " (common:get-last-run-version)) - (if (and (file-exists? mtconf) - (eq? (current-user-id)(file-owner mtconf))) ;; safe to run -cleanup-db - (begin - (debug:print 0 *default-log-port* " I see you are the owner of megatest.config, attempting to cleanup and reset to new version") - (handle-exceptions - exn - (begin - (debug:print 0 *default-log-port* "Failed to switch versions.") - (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) - (print-call-chain (current-error-port)) - (exit 1)) - (common:cleanup-db))) - (begin - (debug:print 0 *default-log-port* " to switch versions you can run: \"megatest -cleanup-db\"") - (exit 1)))))) + (if (common:on-homehost?) + (if (common:api-changed?) + (let* ((mtconf (conc (get-environment-variable "MT_RUN_AREA_HOME") "/megatest.config")) + (dbfile (conc (get-environment-variable "MT_RUN_AREA_HOME") "/megatest.db")) + (read-only (not (file-write-access? dbfile))) + (dbstruct (db:setup #t))) + (debug:print 0 *default-log-port* + "WARNING: Version mismatch!\n" + " expected: " (common:version-signature) "\n" + " got: " (common:get-last-run-version)) + (cond + ((get-environment-variable "MT_SKIP_DB_MIGRATE") #t) + ((and (common:file-exists? mtconf) (common:file-exists? dbfile) (not read-only) + (eq? (current-user-id)(file-owner mtconf))) ;; safe to run -cleanup-db + (debug:print 0 *default-log-port* " I see you are the owner of megatest.config, attempting to cleanup and reset to new version") + (handle-exceptions + exn + (begin + (debug:print 0 *default-log-port* "Failed to switch versions. exn=" exn) + (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) + (print-call-chain (current-error-port)) + (exit 1)) + (common:cleanup-db dbstruct))) + ((not (common:file-exists? mtconf)) + (debug:print 0 *default-log-port* " megatest.config does not exist in this area. Cannot proceed with megatest version migration.") + (exit 1)) + ((not (common:file-exists? dbfile)) + (debug:print 0 *default-log-port* " megatest.db does not exist in this area. Cannot proceed with megatest version migration.") + (exit 1)) + ((not (eq? (current-user-id)(file-owner mtconf))) + (debug:print 0 *default-log-port* " You do not own megatest.db in this area. Cannot proceed with megatest version migration.") + (exit 1)) + (read-only + (debug:print 0 *default-log-port* " You have read-only access to this area. Cannot proceed with megatest version migration.") + (exit 1)) + (else + (debug:print 0 *default-log-port* " to switch versions you can run: \"megatest -cleanup-db\"") + (exit 1))))))) +;; (begin +;; (debug:print 0 *default-log-port* "ERROR: cannot migrate version unless on homehost. Exiting.") +;; (exit 1)))) ;;====================================================================== ;; S P A R S E A R R A Y S ;;====================================================================== @@ -254,10 +694,13 @@ (map common:to-alist (hash-table->alist dat))) (else (if dat dat "")))) + +(define (common:alist-ref/default key alist default) + (or (alist-ref key alist) default)) (define (common:low-noise-print waitval . keys) (let* ((key (string-intersperse (map conc keys) "-" )) (lasttime (hash-table-ref/default *common:denoise* key 0)) (currtime (current-seconds))) @@ -274,11 +717,11 @@ (handle-exceptions exn (handle-exceptions exn (begin - (debug:print-error 0 *default-log-port* "received bad encoded string \"" instr "\", message: " ((condition-property-accessor 'exn 'message) exn)) + (debug:print-error 0 *default-log-port* "received bad encoded string \"" instr "\", message: " ((condition-property-accessor 'exn 'message) exn) ", exn=" exn) (print-call-chain (current-error-port)) #f) (read (open-input-string (base64:base64-decode instr)))) (read (open-input-string (z3:decode-buffer (base64:base64-decode instr)))))) @@ -285,61 +728,180 @@ ;; dot-locking egg seems not to work, using this for now ;; if lock is older than expire-time then remove it and try again ;; to get the lock ;; (define (common:simple-file-lock fname #!key (expire-time 300)) - (if (file-exists? fname) - (if (> (- (current-seconds)(file-modification-time fname)) expire-time) - (begin - (delete-file* fname) - (common:simple-file-lock fname expire-time: expire-time)) - #f) - (let ((key-string (conc (get-host-name) "-" (current-process-id)))) - (with-output-to-file fname - (lambda () - (print key-string))) - (thread-sleep! 0.25) - (if (file-exists? fname) - (with-input-from-file fname - (lambda () - (equal? key-string (read-line)))) - #f)))) - + (let ((fmod-time (handle-exceptions + ext + (current-seconds) + (file-modification-time fname)))) + (if (common:file-exists? fname) + (if (> (- (current-seconds) fmod-time) expire-time) + (begin + (handle-exceptions exn #f (delete-file* fname)) + (common:simple-file-lock fname expire-time: expire-time)) + #f) + (let ((key-string (conc (get-host-name) "-" (current-process-id)))) + (with-output-to-file fname + (lambda () + (print key-string))) + (thread-sleep! 0.25) + (if (common:file-exists? fname) + (handle-exceptions exn + #f + (with-input-from-file fname + (lambda () + (equal? key-string (read-line))))) + #f))))) + +(define (common:simple-file-lock-and-wait fname #!key (expire-time 300)) + (let ((end-time (+ expire-time (current-seconds)))) + (let loop ((got-lock (common:simple-file-lock fname expire-time: expire-time))) + (if got-lock + #t + (if (> end-time (current-seconds)) + (begin + (thread-sleep! 3) + (loop (common:simple-file-lock fname expire-time: expire-time))) + #f))))) + (define (common:simple-file-release-lock fname) - (delete-file* fname)) + (handle-exceptions + exn + #f ;; I don't really care why this failed (at least for now) + (delete-file* fname))) ;;====================================================================== ;; S T A T E S A N D S T A T U S E S ;;====================================================================== -(define *common:std-states* - '((0 "COMPLETED") - (1 "NOT_STARTED") - (2 "RUNNING") - (3 "REMOTEHOSTSTART") - (4 "LAUNCHED") - (5 "KILLED") - (6 "KILLREQ") - (7 "STUCK") - (8 "ARCHIVED"))) - +;; BBnote: *common:std-states* - dashboard filter control and test control state buttons defined here; used in set-fields-panel and dboard:make-controls +(define *common:std-states* ;; for toggle buttons in dashboard + '( + (0 "ARCHIVED") + (1 "STUCK") + (2 "KILLREQ") + (3 "KILLED") + (4 "NOT_STARTED") + (5 "COMPLETED") + (6 "LAUNCHED") + (7 "REMOTEHOSTSTART") + (8 "RUNNING") + )) + +(define *common:dont-roll-up-states* + '("DELETED" + "REMOVING" + "CLEANING" + "ARCHIVE_REMOVING" + )) + +;; BBnote: *common:std-statuses* dashboard filter control and test control status buttons defined here; used in set-fields-panel and dboard:make-controls +;; note these statuses are sorted from better to worse. +;; This sort order is important to dcommon:status-compare3 and db:set-state-status-and-roll-up-items (define *common:std-statuses* - '((0 "PASS") - (1 "WARN") - (2 "FAIL") - (3 "CHECK") - (4 "n/a") + '(;; (0 "DELETED") + (1 "n/a") + (2 "PASS") + (3 "SKIP") + (4 "WARN") (5 "WAIVED") - (6 "SKIP") - (7 "DELETED") - (8 "STUCK/DEAD") - (9 "ABORT"))) - -;; These are stopping conditions that prevent a test from being run -(define *common:cant-run-states-sym* - '(COMPLETED KILLED WAIVED UNKNOWN INCOMPLETE ABORT ARCHIVED)) - + (6 "CHECK") + (7 "STUCK/DEAD") + (8 "DEAD") + (9 "FAIL") + (10 "PREQ_FAIL") + (11 "PREQ_DISCARDED") + (12 "ABORT"))) + +(define *common:ended-states* ;; states which indicate the test is stopped and will not proceed + '("COMPLETED" "ARCHIVED" "KILLED" "KILLREQ" "STUCK" "INCOMPLETE" )) + +(define *common:badly-ended-states* ;; these roll up as CHECK, i.e. results need to be checked + '("KILLED" "KILLREQ" "STUCK" "INCOMPLETE" "DEAD")) + +(define *common:well-ended-states* ;; an item's prereq in this state allows item to proceed + '("PASS" "WARN" "CHECK" "WAIVED" "SKIP")) + +;; BBnote: *common:running-states* used from db:set-state-status-and-roll-up-items +(define *common:running-states* ;; test is either running or can be run + '("RUNNING" "REMOTEHOSTSTART" "LAUNCHED" "STARTED")) + +(define *common:cant-run-states* ;; These are stopping conditions that prevent a test from being run + '("COMPLETED" "KILLED" "UNKNOWN" "INCOMPLETE" "ARCHIVED")) + +(define *common:not-started-ok-statuses* ;; if not one of these statuses when in not_started state treat as dead + '("n/a" "na" "PASS" "FAIL" "WARN" "CHECK" "WAIVED" "DEAD" "SKIP")) + +;; group tests into buckets corresponding to rollup +;;; Running, completed-pass, completed-non-pass + worst status, not started. +;; filter out +;(define (common:categorize-items-for-rollup in-tests) +; ( + +(define (common:special-sort items order comp) + (let ((items-order (map reverse order)) + (acomp (or comp >))) + (sort items + (lambda (a b) + (let ((a-num (cadr (or (assoc a items-order) '(0 0)))) + (b-num (cadr (or (assoc b items-order) '(0 0))))) + (acomp a-num b-num)))))) + +;; ;; given a toplevel with currstate, currstatus apply state and status +;; ;; => (newstate . newstatus) +;; (define (common:apply-state-status currstate currstatus state status) +;; (let* ((cstate (string->symbol (string-downcase currstate))) +;; (cstatus (string->symbol (string-downcase currstatus))) +;; (sstate (string->symbol (string-downcase state))) +;; (sstatus (string->symbol (string-downcase status))) +;; (nstate #f) +;; (nstatus #f)) +;; (set! nstate +;; (case cstate +;; ((completed not_started killed killreq stuck archived) +;; (case sstate ;; completed -> sstate +;; ((completed killed killreq stuck archived) completed) +;; ((running remotehoststart launched) running) +;; (else unknown-error-1))) +;; ((running remotehoststart launched) +;; (case sstate +;; ((completed killed killreq stuck archived) #f) ;; need to look at all items +;; ((running remotehoststart launched) running) +;; (else unknown-error-2))) +;; (else unknown-error-3))) +;; (set! nstatus +;; (case sstatus +;; ((pass) +;; (case nstate +;; ((pass n/a deleted) pass) +;; ((warn) warn) +;; ((fail) fail) +;; ((check) check) +;; ((waived) waived) +;; ((skip) skip) +;; ((stuck/dead) stuck) +;; ((abort) abort) +;; (else unknown-error-4))) +;; ((warn) +;; (case nstate +;; ((pass warn n/a skip deleted) warn) +;; ((fail) fail) +;; ((check) check) +;; ((waived) waived) +;; ((stuck/dead) stuck) +;; (else unknown-error-5))) +;; ((fail) +;; (case nstate +;; ((pass warn fail check n/a waived skip deleted stuck/dead stuck) fail) +;; ((abort) abort) +;; (else unknown-error-6))) +;; (else unknown-error-7))) +;; (cons +;; (if nstate (symbol->string nstate) nstate) +;; (if nstatus (symbol->string nstatus) nstatus)))) + ;;====================================================================== ;; D E B U G G I N G S T U F F ;;====================================================================== (define *verbosity* 1) @@ -352,96 +914,233 @@ (define (assoc/default key lst . default) (let ((res (assoc key lst))) (if res (cadr res)(if (null? default) #f (car default))))) (define (common:get-testsuite-name) - (or (configf:lookup *configdat* "setup" "testsuite" ) - (pathname-file *toppath*))) + (or (configf:lookup *configdat* "setup" "area-name") ;; megatest is a flexible tool, testsuite is too limiting a description. + (configf:lookup *configdat* "setup" "testsuite" ) + (getenv "MT_TESTSUITE_NAME") + (pathname-file (or (if (string? *toppath* ) + (pathname-file *toppath*) + #f) + (common:get-topath #f))) + "please-set-setup-area-name")) ;; (pathname-file (current-directory))))) + +;; safe getting of toppath +(define (common:get-toppath areapath) + (or *toppath* + (if areapath + (begin + (set! *toppath* areapath) + (setenv "MT_RUN_AREA_HOME" areapath) + areapath) + #f) + (if (getenv "MT_RUN_AREA_HOME") + (begin + (set! *toppath* (getenv "MT_RUN_AREA_HOME")) + *toppath*) + #f) + ;; last resort, look for megatest.config + (let loop ((thepath (realpath "."))) + (if (file-exists? (conc thepath "/megatest.config")) + thepath + (if (equal? thepath "/") + (begin + (debug:print-error 0 *default-log-port* "Unable to find megatest home directory.") + #f) + (loop (pathname-directory thepath))))) + )) + +(define common:get-area-name common:get-testsuite-name) + +(define (common:get-db-tmp-area . junk) + (if *db-cache-path* + *db-cache-path* + (if *toppath* ;; common:get-create-writeable-dir + (handle-exceptions + exn + (begin + (debug:print-error 0 *default-log-port* "Couldn't create path to " *db-cache-path* ", exn=" exn) + (exit 1)) + (let* ((tsname (common:get-testsuite-name)) + (dbpath (common:get-create-writeable-dir + (list (conc "/tmp/" (current-user-name) + "/megatest_localdb/" + tsname "/" + (string-translate *toppath* "/" ".")) + (conc "/tmp/" (current-process-id) ;; just in case we have an issue with the dir by own user name + "/megatest_localdb/" + tsname + (string-translate *toppath* "/" ".")) + )))) + (set! *db-cache-path* dbpath) + dbpath)) + #f))) + +(define (common:get-area-path-signature) + (message-digest-string (md5-primitive) *toppath*)) + +(define (common:get-signature str) + (message-digest-string (md5-primitive) str)) ;;====================================================================== ;; E X I T H A N D L I N G ;;====================================================================== -(define (common:legacy-sync-recommended) - (or (args:get-arg "-runtests") - (args:get-arg "-server") - ;; (args:get-arg "-set-run-status") - (args:get-arg "-remove-runs") - ;; (args:get-arg "-get-run-status") - )) - -(define (common:legacy-sync-required) - (configf:lookup *configdat* "setup" "megatest-db")) +(define (common:run-sync?) + (and (common:on-homehost?) + (args:get-arg "-server"))) + +;; (let ((ohh (common:on-homehost?)) +;; (srv (args:get-arg "-server"))) +;; (and ohh srv))) + ;; (debug:print-info 0 *default-log-port* "common:run-sync? ohh=" ohh ", srv=" srv) + + + +(define *wdnum* 0) +(define *wdnum*mutex (make-mutex)) + + +(define (common:human-time) + (time->string (seconds->local-time (current-seconds)) "%Y-%m-%d %H:%M:%S")) + + +;; currently the primary job of the watchdog is to run the sync back to megatest.db from the db in /tmp +;; if we are on the homehost and we are a server (by definition we are on the homehost if we are a server) +;; +(define (common:readonly-watchdog dbstruct) + (thread-sleep! 0.05) ;; delay for startup + (debug:print-info 13 *default-log-port* "common:readonly-watchdog entered.") + ;; sync megatest.db to /tmp/.../megatst.db + (let* ((sync-cool-off-duration 3) + (golden-mtdb (dbr:dbstruct-mtdb dbstruct)) + (golden-mtpath (db:dbdat-get-path golden-mtdb)) + (tmp-mtdb (dbr:dbstruct-tmpdb dbstruct)) + (tmp-mtpath (db:dbdat-get-path tmp-mtdb))) + (debug:print-info 0 *default-log-port* "Read-only periodic sync thread started.") + (let loop ((last-sync-time 0)) + (debug:print-info 13 *default-log-port* "loop top tmp-mtpath="tmp-mtpath" golden-mtpath="golden-mtpath) + (let* ((duration-since-last-sync (- (current-seconds) last-sync-time))) + (debug:print-info 13 *default-log-port* "duration-since-last-sync="duration-since-last-sync) + (if (and (not *time-to-exit*) + (< duration-since-last-sync sync-cool-off-duration)) + (thread-sleep! (- sync-cool-off-duration duration-since-last-sync))) + (if (not *time-to-exit*) + (let ((golden-mtdb-mtime (file-modification-time golden-mtpath)) + (tmp-mtdb-mtime (file-modification-time tmp-mtpath))) + (if (> golden-mtdb-mtime tmp-mtdb-mtime) + (if (< golden-mtdb-mtime (- (current-seconds) 3)) ;; file has NOT been touched in past three seconds, this way multiple servers won't fight to sync back + (let ((res (db:multi-db-sync dbstruct 'old2new))) + (debug:print-info 13 *default-log-port* "rosync called, " res " records transferred.")))) + (loop (current-seconds))) + #t))) + (debug:print-info 0 *default-log-port* "Exiting readonly-watchdog timer, *time-to-exit* = " *time-to-exit*" pid="(current-process-id)" mtpath="golden-mtpath))) + +;; TODO: for multiple areas, we will have multiple watchdogs; and multiple threads to manage +(define (common:watchdog) + (debug:print-info 13 *default-log-port* "common:watchdog entered.") + (if (launch:setup) + (if (common:on-homehost?) + (let ((dbstruct (db:setup #t))) + (debug:print-info 13 *default-log-port* "after db:setup with dbstruct=" dbstruct) + (cond + ((dbr:dbstruct-read-only dbstruct) + (debug:print-info 13 *default-log-port* "loading read-only watchdog") + (common:readonly-watchdog dbstruct)) + (else + (debug:print-info 13 *default-log-port* "loading writable-watchdog.") + (let* ((syncer (or (configf:lookup *configdat* "server" "sync-method") "delta-sync"))) ;; "brute-force-sync"))) + (cond + ((equal? syncer "brute-force-sync") + (server:writable-watchdog-bruteforce dbstruct)) + ((equal? syncer "delta-sync") + (server:writable-watchdog-deltasync dbstruct)) + (else + (debug:print-error 0 *default-log-port* "Unknown server/sync-method specified ("syncer") - valid values are brute-force-sync and delta-sync.") + (exit 1))) + ;;(debug:print 1 *default-log-port* "INFO: ["(common:human-time)"] Syncer started (method="syncer")") + ))) + (debug:print-info 13 *default-log-port* "watchdog done.")) + (debug:print-info 13 *default-log-port* "no need for watchdog on non-homehost")))) + (define (std-exit-procedure) + ;;(common:telemetry-log-close) + (on-exit (lambda () 0)) + ;;(debug:print-info 13 *default-log-port* "std-exit-procedure called; *time-to-exit*="*time-to-exit*) (let ((no-hurry (if *time-to-exit* ;; hurry up #f (begin (set! *time-to-exit* #t) #t)))) (debug:print-info 4 *default-log-port* "starting exit process, finalizing databases.") (if (and no-hurry (debug:debug-mode 18)) (rmt:print-db-stats)) (let ((th1 (make-thread (lambda () ;; thread for cleaning up, give it five seconds - (let ((run-ids (hash-table-keys *db-local-sync*))) - (if (and (not (null? run-ids)) - (or (common:legacy-sync-recommended) - (configf:lookup *configdat* "setup" "megatest-db"))) - (if no-hurry (db:multi-db-sync run-ids 'new2old)))) - (if *dbstruct-db* (db:close-all *dbstruct-db*)) - (if *inmemdb* (db:close-all *inmemdb*)) - (if (and *megatest-db* - (sqlite3:database? *megatest-db*)) - (begin - (sqlite3:interrupt! *megatest-db*) - (sqlite3:finalize! *megatest-db* #t) - (set! *megatest-db* #f))) + (if *dbstruct-db* (db:close-all *dbstruct-db*)) ;; one second allocated (if *task-db* (let ((db (cdr *task-db*))) (if (sqlite3:database? db) (begin (sqlite3:interrupt! db) (sqlite3:finalize! db #t) - (vector-set! *task-db* 0 #f))))) - (close-output-port *default-log-port*) + ;; (vector-set! *task-db* 0 #f) + (set! *task-db* #f))))) + (http-client#close-all-connections!) + ;; (if (and *runremote* + ;; (remote-conndat *runremote*)) + ;; (begin + ;; (http-client#close-all-connections!))) ;; for http-client + (if (not (eq? *default-log-port* (current-error-port))) + (close-output-port *default-log-port*)) (set! *default-log-port* (current-error-port))) "Cleanup db exit thread")) (th2 (make-thread (lambda () (debug:print 4 *default-log-port* "Attempting clean exit. Please be patient and wait a few seconds...") (if no-hurry - (thread-sleep! 5) ;; give the clean up few seconds to do it's stuff - (thread-sleep! 2)) - (debug:print 4 *default-log-port* " ... done") - ) + (begin + (thread-sleep! 5)) ;; give the clean up few seconds to do it's stuff + (begin + (thread-sleep! 2))) + (debug:print 4 *default-log-port* " ... done") + ) "clean exit"))) (thread-start! th1) (thread-start! th2) - (thread-join! th1)))) + (thread-join! th1) + ) + ) + + 0) (define (std-signal-handler signum) ;; (signal-mask! signum) + (set! *time-to-exit* #t) + ;;(debug:print-info 13 *default-log-port* "got signal "signum) + (debug:print-error 0 *default-log-port* "Received signal " signum " aaa exiting promptly") + ;; (std-exit-procedure) ;; shouldn't need this since we are exiting and it will be called anyway + (exit)) + +(define (special-signal-handler signum) + ;; (signal-mask! signum) (set! *time-to-exit* #t) - (debug:print-error 0 *default-log-port* "Received signal " signum " exiting promptly") + ;;(debug:print-info 13 *default-log-port* "got signal "signum) + (debug:print-error 0 *default-log-port* "Received signal " signum " sending email befor exiting!!") + ;;TODO send email to notify admin contact listed in the config that the lisner got killed ;; (std-exit-procedure) ;; shouldn't need this since we are exiting and it will be called anyway (exit)) + (set-signal-handler! signal/int std-signal-handler) ;; ^C (set-signal-handler! signal/term std-signal-handler) + ;; (set-signal-handler! signal/stop std-signal-handler) ;; ^Z NO, do NOT handle ^Z! ;;====================================================================== ;; M I S C U T I L S ;;====================================================================== -;; one-of args defined -(define (args-defined? . param) - (let ((res #f)) - (for-each - (lambda (arg) - (if (args:get-arg arg)(set! res #t))) - param) - res)) - ;; convert stuff to a number if possible (define (any->number val) (cond ((number? val) val) ((string? val) (string->number val)) @@ -463,15 +1162,119 @@ (if (string-match (regexp modpatt) item) (set! res #t)))) (string-split patts ",")) res) #t)) + +;; '(print (string-intersperse (map cadr (hash-table-ref/default (read-config "megatest.config" \#f \#t) "disks" '"'"'("none" ""))) "\n"))' +(define (common:get-disks #!key (configf #f)) + (hash-table-ref/default + (or configf (read-config "megatest.config" #f #t)) + "disks" '("none" ""))) + +;; return first command that exists, else #f +;; +(define (common:which cmds) + (if (null? cmds) + #f + (let loop ((hed (car cmds)) + (tal (cdr cmds))) + (let ((res (with-input-from-pipe (conc "which " hed) read-line))) + (if (and (string? res) + (common:file-exists? res)) + res + (if (null? tal) + #f + (loop (car tal)(cdr tal)))))))) + +(define (common:get-install-area) + (let ((exe-path (car (argv)))) + (if (common:file-exists? exe-path) + (handle-exceptions + exn + #f + (pathname-directory + (pathname-directory + (pathname-directory exe-path)))) + #f))) + +;; return first path that can be created or already exists and is writable +;; +(define (common:get-create-writeable-dir dirs) + (if (null? dirs) + #f + (let loop ((hed (car dirs)) + (tal (cdr dirs))) + (let ((res (or (and (directory? hed) + (file-write-access? hed) + hed) + (handle-exceptions + exn + (begin + (debug:print-info 0 *default-log-port* "could not create " hed + ", this might cause problems down the road. exn=" exn) + #f) + (create-directory hed #t))))) + (if (and (string? res) + (directory? res)) + res + (if (null? tal) + #f + (loop (car tal)(cdr tal)))))))) + +;; return the youngest timestamp . filename +;; +(define (common:get-youngest glob-list) + (let ((all-files (apply append + (map (lambda (patt) + (handle-exceptions + exn + '() + (glob patt))) + glob-list)))) + (fold (lambda (fname res) + (let ((last-mod (car res)) + (curmod (handle-exceptions + exn + 0 + (file-modification-time fname)))) + (if (> curmod last-mod) + (list curmod fname) + res))) + '(0 "n/a") + all-files))) + +;; use bash to expand a glob. Does NOT handle paths with spaces! +;; +(define (common:bash-glob instr) + (string-split + (with-input-from-pipe + (conc "/bin/bash -c \"echo " instr "\"") + read-line))) + +;;====================================================================== +;; Some safety net stuff +;;====================================================================== + +;; return input if it is a list or return null +(define (common:list-or-null inlst #!key (ovrd #f)(message #f)) + (if (list? inlst) + inlst + (begin + (if message (debug:print-error 0 *default-log-port* message)) + (or ovrd '())))) + +;;====================================================================== +;; T A R G E T S , S T A T E , S T A T U S , +;; R U N N A M E A N D T E S T P A T T +;;====================================================================== ;; (map print (map car (hash-table->alist (read-config "runconfigs.config" #f #t)))) +;; (define (common:get-runconfig-targets #!key (configf #f)) (let ((targs (sort (map car (hash-table->alist - (or configf + (or configf ;; NOTE: There is no value in using runconfig:read here. (read-config (conc *toppath* "/runconfigs.config") #f #t) (make-hash-table)))) string trynum 0) + (begin + (thread-sleep! 2) + (common:get-homehost trynum: (- trynum 1))) + #f)) + (else + (let* ((currhost (get-host-name)) + (bestadrs (server:get-best-guess-address currhost)) + ;; first look in config, then look in file .homehost, create it if not found + (homehost (or (configf:lookup *configdat* "server" "homehost" ) + (handle-exceptions + exn + (if (> trynum 0) + (let ((delay-time (* (- 5 trynum) 5))) + (mutex-unlock! *homehost-mutex*) + (debug:print 0 *default-log-port* "ERROR: ["(common:human-time)"] Failed to read .homehost file, delaying " + delay-time " seconds and trying again, message: " ((condition-property-accessor 'exn 'message) exn) + ", exn=" exn) + (thread-sleep! delay-time) + (common:get-homehost trynum: (- trynum 1))) + (begin + (mutex-unlock! *homehost-mutex*) + (debug:print 0 *default-log-port* "ERROR: ["(common:human-time) + "] Failed to read .homehost file after trying five times. Giving up and exiting, message: " + ((condition-property-accessor 'exn 'message) exn)) + (exit 1))) + (let ((hhf (conc *toppath* "/.homehost"))) + (if (common:file-exists? hhf) + (with-input-from-file hhf read-line) + (if (file-write-access? *toppath*) + (begin + (with-output-to-file hhf + (lambda () + (print bestadrs))) + (begin + (mutex-unlock! *homehost-mutex*) + (car (common:get-homehost)))) + #f)))))) + (at-home (or (equal? homehost currhost) + (equal? homehost bestadrs)))) + (set! *home-host* (cons homehost at-home)) + (mutex-unlock! *homehost-mutex*) + *home-host*)))) + +;; am I on the homehost? +;; +(define (common:on-homehost?) + (let ((hh (common:get-homehost))) + (if hh + (cdr hh) + #f))) + +;; do we honor the caches of the config files? +;; +(define (common:use-cache?) + (let ((res #t)) ;; priority by order of evaluation + (if *configdat* ;; sillyness here. can't use setup/use-cache to know if we can use the cached files! + (if (equal? (configf:lookup *configdat* "setup" "use-cache") "no") + (set! res #f) + (if (equal? (configf:lookup *configdat* "setup" "use-cache") "yes") + (set! res #t)))) + (if (args:get-arg "-no-cache")(set! res #f)) ;; overrides setting in "setup" + (if (getenv "MT_USE_CACHE") + (if (equal? (getenv "MT_USE_CACHE") "yes") + (set! res #t) + (if (equal? (getenv "MT_USE_CACHE") "no") + (set! res #f)))) ;; overrides -no-cache switch + res)) + +;; force use of server? +;; +(define (common:force-server?) + (let* ((force-setting (configf:lookup *configdat* "server" "force")) + (force-type (if force-setting (string->symbol force-setting) #f)) + (force-result (case force-type + ((#f) #f) + ((always) #t) + ((test) (if (args:get-arg "-execute") ;; we are in a test + #t + #f)) + (else + (debug:print 0 *default-log-port* "ERROR: Bad server force setting " force-setting ", forcing server.") + #t)))) ;; default to requiring server + (if force-result + (begin + (debug:print-info 0 *default-log-port* "forcing use of server, force setting is \"" force-setting "\".") + #t) + #f))) ;;====================================================================== ;; M I S C L I S T S ;;====================================================================== @@ -572,10 +1545,11 @@ (if (null? tala) ;; we are done talb (loop (car tala) (cdr tala) (car talb) + (cdr talb))) #f))))) ;; Needed for long lists to be sorted where (apply max ... ) dies ;; @@ -587,10 +1561,86 @@ (loop (max hed max-val) (car tal) (cdr tal)) (max hed max-val)))) +;; get min or max, use > for max and < for min, this works around the limits on apply +;; +(define (common:min-max comp lst) + (if (null? lst) + #f ;; better than an exception for my needs + (fold (lambda (a b) + (if (comp a b) a b)) + (car lst) + lst))) + +;; get min or max, use > for max and < for min, this works around the limits on apply +;; +(define (common:sum lst) + (if (null? lst) + 0 + (fold (lambda (a b) + (+ a b)) + (car lst) + lst))) + +;; path list to hash-table tree +;; ((a b c)(a b d)(e b c)) => ((a (b (d) (c))) (e (b (c)))) +;; +(define (common:list->htree lst) + (let ((resh (make-hash-table))) + (for-each + (lambda (inlst) + (let loop ((ht resh) + (hed (car inlst)) + (tal (cdr inlst))) + (if (hash-table-ref/default ht hed #f) + (if (not (null? tal)) + (loop (hash-table-ref ht hed) + (car tal) + (cdr tal))) + (begin + (hash-table-set! ht hed (make-hash-table)) + (loop ht hed tal))))) + lst) + resh)) + +;; hash-table tree to html list tree +;; +;; tipfunc takes two parameters: y the tip value and path the path to that point +;; +(define (common:htree->html ht path tipfunc) + (let ((datlist (sort (hash-table->alist ht) + (lambda (a b) + (string< (car a)(car b)))))) + (if (null? datlist) + (tipfunc #f path) ;; really shouldn't get here + (s:ul + (map (lambda (x) + (let* ((levelname (car x)) + (y (cdr x)) + (newpath (append path (list levelname))) + (leaf (or (not (hash-table? y)) + (null? (hash-table-keys y))))) + (if leaf + (s:li (tipfunc y newpath)) + (s:li + (list + levelname + (common:htree->html y newpath tipfunc)))))) + datlist))))) + +;; hash-table tree to alist tree +;; +(define (common:htree->atree ht) + (map (lambda (x) + (cons (car x) + (let ((y (cdr x))) + (if (hash-table? y) + (common:htree->atree y) + y)))) + (hash-table->alist ht))) ;;====================================================================== ;; M U N G E D A T A I N T O N I C E F O R M S ;;====================================================================== @@ -630,14 +1680,65 @@ new-rownames new-colnames (if (> curr-rownum rownum) curr-rownum rownum) (if (> curr-colnum colnum) curr-colnum colnum) )))))) + +;; if it looks like a number -> convert it to a number, else return it +;; +(define (common:lazy-convert inval) + (let* ((as-num (if (string? inval)(string->number inval) #f))) + (or as-num inval))) + +;; convert string a=1; b=2; c=a silly thing; d= +;; to '((a . 1)(b . 2)(c . "a silly thing")(d . "")) +;; +(define (common:val->alist val #!key (convert #f)) + (let ((val-list (string-split-fields ";\\s*" val #:infix))) + (if val-list + (map (lambda (x) + (let ((f (string-split-fields "\\s*=\\s*" x #:infix))) + (case (length f) + ((0) `(,#f)) ;; null string case + ((1) `(,(string->symbol (car f)))) + ((2) `(,(string->symbol (car f)) . ,(let ((inval (cadr f))) + (if convert (common:lazy-convert inval) inval)))) + (else f)))) + val-list) + '()))) ;;====================================================================== ;; S Y S T E M S T U F F ;;====================================================================== + +;; lazy-safe get file mod time. on any error (file not existing etc.) return 0 +;; +(define (common:lazy-modification-time fpath) + (handle-exceptions + exn + (begin + (debug:print 0 *default-log-port* "Failed to get modifcation time for " fpath ", treating it as zero. exn=" exn) + 0) + (if (file-exists? fpath) + (file-modification-time fpath) + 0))) + +;; find timestamp of newest file associated with a sqlite db file +(define (common:lazy-sqlite-db-modification-time fpath) + (let* ((glob-list (handle-exceptions + exn + (begin + (debug:print 0 *default-log-port* "Failed to glob " fpath "*, exn=" exn) + `(,(conc "/no/such/file, message: " ((condition-property-accessor 'exn 'message) exn)))) + (glob (conc fpath "*")))) + (file-list (if (eq? 0 (length glob-list)) + '("/no/such/file") + glob-list))) + (apply max + (map + common:lazy-modification-time + file-list)))) ;; return a nice clean pathname made absolute (define (common:nice-path dir) (let ((match (string-match "^(~[^\\/]*)(\\/.*|)$" dir))) (if match ;; using ~ for home? @@ -651,19 +1752,63 @@ (define (common:read-link-f path) (handle-exceptions exn (begin - (debug:print-error 0 *default-log-port* "command \"/bin/readlink -f " path "\" failed.") + (debug:print-error 0 *default-log-port* "command \"/bin/readlink -f " path "\" failed. exn=" exn) path) ;; just give up (with-input-from-pipe (conc "/bin/readlink -f " path) (lambda () (read-line))))) -(define (get-cpu-load) - (car (common:get-cpu-load))) +;; returns *effective load* (not normalized) +;; +(define (common:get-intercept onemin fivemin) + (if (< onemin fivemin) ;; load is decreasing, just use the onemin load + onemin + (let* ((load-change (- onemin fivemin)) + (tchange (- 300 60))) + (max (+ onemin (* 60 (/ load-change tchange))) 0)))) + +;; calculate a delay number based on a droop curve +;; inputs are: +;; - load-in, load as from uptime, NOT normalized +;; - numcpus, number of cpus, ideally use the real cpus, not threads +;; +(define (common:get-delay load-in numcpus) + (let* ((ratio (/ load-in numcpus)) + (new-option (configf:lookup *configdat* "load" "new-load-method")) + (paramstr (or (configf:lookup *configdat* "load" "exp-params") + "15 12 1281453987.9543 0.75")) ;; 5 4 10 1")) + (paramlst (map string->number (string-split paramstr)))) + (if new-option + (begin + (cond ((and (>= ratio 0) (< ratio .5)) + 0) + ((and (>= ratio 0.5) (<= ratio .9)) + (* ratio (/ 5 .9))) + ((and (> ratio .9) (<= ratio 1.1)) + (+ 5 (* (- ratio .9) (/ 55 .2)))) + ((> ratio 1.1) + 60))) + (match paramlst + ((r1 r2 s1 s2) + (debug:print 3 *default-log-port* "Using params r1=" r1 " r2=" r2 " s1=" s1 " s2=" s2) + (min (max (/ (expt r1 (* r2 s2 ratio)) s1) 0) 30)) + (else + (debug:print 0 *default-log-port* "BAD exp-params, should be \"r1 r2 s1 s2\" but got " paramstr) + 30))))) + +(define (common:print-delay-table) + (let loop ((x 0)) + (print x "," (common:get-delay x 1)) + (if (< x 2) + (loop (+ x 0.1))))) + +(define (get-cpu-load #!key (remote-host #f)) + (car (common:get-cpu-load remote-host))) ;; (let* ((load-res (process:cmd-run->list "uptime")) ;; (load-rx (regexp "load average:\\s+(\\d+)")) ;; (cpu-load #f)) ;; (for-each (lambda (l) ;; (let ((match (string-search load-rx l))) @@ -671,53 +1816,520 @@ ;; (let ((newval (string->number (cadr match)))) ;; (if (number? newval) ;; (set! cpu-load newval)))))) ;; (car load-res)) ;; cpu-load)) + +;; get values from cached info from dropping file in logs dir +;; e.g. key is host and dtype is normalized-load +;; +(define (common:get-cached-info key dtype #!key (age 10)) + (if *toppath* + (let* ((fullpath (conc *toppath* "/.sysdata/" key "-" dtype ".log")) + (delfile (lambda () + (debug:print-info 1 *default-log-port* " removing bad file " fullpath ", exn=" exn) + (delete-file* fullpath) + #f))) + (if (and (file-exists? fullpath) + (file-read-access? fullpath)) + (handle-exceptions + exn + (begin + (debug:print 0 *default-log-port* "failed to get cached info from " fullpath ", exn=" exn) + #f) + (debug:print 2 *default-log-port* "reading file " fullpath) + (let ((real-age (- (current-seconds) + (handle-exceptions + exn + (begin + (debug:print 1 *default-log-port* "Failed to read mod time on file " + fullpath ", using 0, exn=" exn) + 0) + (file-change-time fullpath))))) + (if (< real-age age) + (handle-exceptions + exn + (delfile) + (let* ((res (with-input-from-file fullpath read))) + (if (eof-object? res) + (begin + (delfile) + #f) + res))) + (begin + (debug:print-info 2 *default-log-port* "file " fullpath + " is too old (" real-age" seconds) to trust, skipping reading it") + #f)))) + (begin + (debug:print 2 *default-log-port* "not reading file " fullpath) + #f))) + #f)) + +(define (common:write-cached-info key dtype dat) + (if *toppath* + (let* ((fulldir (conc *toppath* "/.sysdata")) + (fullpath (conc fulldir "/" key "-" dtype ".log"))) + (if (not (file-exists? fulldir))(create-directory fulldir #t)) + (handle-exceptions + exn + (begin + (debug:print 0 *default-log-path* "failed to write file " fullpath ", exn=" exn) + #f) + (with-output-to-file fullpath (lambda ()(pp dat))))) + #f)) + +(define (common:raw-get-remote-host-load remote-host) + (handle-exceptions + exn + (begin + (debug:print 0 *default-log-port* "failed to ssh to " remote-host " and get loadavg. exn=" exn) + #f) ;; more specific handling of errors needed + (with-input-from-pipe + (conc "ssh " remote-host " cat /proc/loadavg") + (lambda ()(list (read)(read)(read)))))) ;; get cpu load by reading from /proc/loadavg, return all three values ;; -(define (common:get-cpu-load) - (with-input-from-file "/proc/loadavg" - (lambda ()(list (read)(read)(read))))) - -(define (common:wait-for-cpuload maxload numcpus waitdelay #!key (count 1000) (msg #f)) - (let* ((loadavg (common:get-cpu-load)) - (first (car loadavg)) - (next (cadr loadavg)) - (adjload (* maxload numcpus)) - (loadjmp (- first next))) +(define (common:get-cpu-load remote-host) + (handle-exceptions + exn + (begin + (debug:print 0 *default-log-port* "failed to ssh or read loadavg from host " remote-host ", exn=" exn) + '(-99 -99 -99)) + (let* ((actual-hostname (or remote-host (get-host-name) "localhost"))) + (or (common:get-cached-info actual-hostname "cpu-load") + (let ((result (if remote-host + (map (lambda (res) + (if (eof-object? res) 9e99 res)) + (with-input-from-pipe + (conc "ssh " remote-host " cat /proc/loadavg") + (lambda ()(list (read)(read)(read))))) + (with-input-from-file "/proc/loadavg" + (lambda ()(list (read)(read)(read))))))) + (match + result + ((l1 l2 l3) + (if (and (number? l1) + (number? l2) + (number? l3)) + (begin + (common:write-cached-info actual-hostname "cpu-load" result) + result) + '(-1 -1 -1))) ;; -1 is bad result + (else '(-2 -2 -2)))))))) + +;; get normalized cpu load by reading from /proc/loadavg and /proc/cpuinfo return all three values and the number of real cpus and the number of threads +;; returns alist '((adj-cpu-load . normalized-proc-load) ... etc. +;; keys: adj-proc-load, adj-core-load, 1m-load, 5m-load, 15m-load +;; +(define (common:get-normalized-cpu-load remote-host) + (let ((res (common:get-normalized-cpu-load-raw remote-host)) + (default `((adj-proc-load . 2) ;; there is no right answer + (adj-core-load . 2) + (1m-load . 2) + (5m-load . 0) ;; causes a large delta - thus causing default of throttling if stuff goes wrong + (15m-load . 0) + (proc . 1) + (core . 1) + (phys . 1) + (error . #t)))) + (cond + ((and (list? res) + (> (length res) 2)) + res) + ((eq? res #f) default) ;; add messages? + ((eq? res #f) default) ;; this would be the #eof + (else default)))) + +(define (common:get-normalized-cpu-load-raw remote-host) + (let* ((actual-host (or remote-host (get-host-name)))) ;; #f is localhost + (or (common:get-cached-info actual-host "normalized-load") + (let ((data (if remote-host + (with-input-from-pipe + (conc "ssh " remote-host " \"cat /proc/loadavg;cat /proc/cpuinfo;echo end\"") + read-lines) + (append + (with-input-from-file "/proc/loadavg" + read-lines) + (with-input-from-file "/proc/cpuinfo" + read-lines) + (list "end")))) + (load-rx (regexp "^([\\d\\.]+)\\s+([\\d\\.]+)\\s+([\\d\\.]+)\\s+.*$")) + (proc-rx (regexp "^processor\\s+:\\s+(\\d+)\\s*$")) + (core-rx (regexp "^core id\\s+:\\s+(\\d+)\\s*$")) + (phys-rx (regexp "^physical id\\s+:\\s+(\\d+)\\s*$")) + (max-num (lambda (p n)(max (string->number p) n)))) + ;; (print "data=" data) + (if (null? data) ;; something went wrong + #f + (let loop ((hed (car data)) + (tal (cdr data)) + (loads #f) + (proc-num 0) ;; processor includes threads + (phys-num 0) ;; physical chip on motherboard + (core-num 0)) ;; core + ;;; (print hed ", " loads ", " proc-num ", " phys-num ", " core-num) + (if (null? tal) ;; have all our data, calculate normalized load and return result + (let* ((act-proc (+ proc-num 1)) + (act-phys (+ phys-num 1)) + (act-core (+ core-num 1)) + (adj-proc-load (/ (car loads) act-proc)) + (adj-core-load (/ (car loads) act-core)) + (result + (append (list (cons 'adj-proc-load adj-proc-load) + (cons 'adj-core-load adj-core-load)) + (list (cons '1m-load (car loads)) + (cons '5m-load (cadr loads)) + (cons '15m-load (caddr loads))) + (list (cons 'proc act-proc) + (cons 'core act-core) + (cons 'phys act-phys))))) + (common:write-cached-info actual-host "normalized-load" result) + result) + (regex-case + hed + (load-rx ( x l1 l5 l15 ) (loop (car tal)(cdr tal)(map string->number (list l1 l5 l15)) proc-num phys-num core-num)) + (proc-rx ( x p ) (loop (car tal)(cdr tal) loads (max-num p proc-num) phys-num core-num)) + (phys-rx ( x p ) (loop (car tal)(cdr tal) loads proc-num (max-num p phys-num) core-num)) + (core-rx ( x c ) (loop (car tal)(cdr tal) loads proc-num phys-num (max-num c core-num))) + (else + (begin + ;; (print "NO MATCH: " hed) + (loop (car tal)(cdr tal) loads proc-num phys-num core-num))))))))))) + +(define (common:unix-ping hostname) + (let ((res (system (conc "ping -c 1 " hostname " > /dev/null")))) + (eq? res 0))) + +;; ideally put all this info into the db, no need to preserve it across moving homehost +;; +;; return list of +;; ( reachable? cpuload update-time ) +(define (common:get-host-info hostname) + (let* ((loadinfo (rmt:get-latest-host-load hostname)) ;; if this host happens to have been recently used by a test reuse the load data + (load (car loadinfo)) + (load-sample-time (cdr loadinfo)) + (load-sample-age (- (current-seconds) load-sample-time)) + (loadinfo-timeout-seconds 6) ;; this was 20 seconds, seems way too lax. Switch to 6 seconds + (host-last-update-timeout-seconds 4) + (host-rec (hash-table-ref/default *host-loads* hostname #f)) + ) (cond - ((and (> first adjload) - (> count 0)) - (debug:print-info 0 *default-log-port* "waiting " waitdelay " seconds due to load " first " exceeding max of " adjload (if msg msg "")) - (thread-sleep! waitdelay) - (common:wait-for-cpuload maxload numcpus waitdelay count: (- count 1))) - ((and (> loadjmp numcpus) - (> count 0)) - (debug:print-info 0 *default-log-port* "waiting " waitdelay " seconds due to load jump " loadjmp " > numcpus " numcpus (if msg msg "")) - (thread-sleep! waitdelay) - (common:wait-for-cpuload maxload numcpus waitdelay count: (- count 1)))))) - -(define (common:get-num-cpus) - (with-input-from-file "/proc/cpuinfo" - (lambda () - (let loop ((numcpu 0) - (inl (read-line))) - (if (eof-object? inl) - numcpu - (loop (if (string-match "^processor\\s+:\\s+\\d+$" inl) - (+ numcpu 1) - numcpu) - (read-line))))))) + ((< load-sample-age loadinfo-timeout-seconds) + (list #t + load-sample-time + load)) + ((and host-rec + (< (current-seconds) (+ (host-last-update host-rec) host-last-update-timeout-seconds))) + (list #t + (host-last-update host-rec) + (host-last-cpuload host-rec ))) + ((common:unix-ping hostname) + (list #t + (current-seconds) + (alist-ref 'adj-core-load (common:get-normalized-cpu-load hostname)))) ;; this is cheaper than you might think. get-normalized-cpu-load is cached for up to 5 seconds + (else + (list #f 0 -1) ;; bad host, don't use! + )))) + +;; see defstruct host at top of file. +;; host: reachable last-update last-used last-cpuload +;; +(define (common:update-host-loads-table hosts-raw) + (let* ((hosts (filter (lambda (x) + (string-match (regexp "^\\S+$") x)) + hosts-raw))) + (for-each + (lambda (hostname) + (let* ((rec (let ((h (hash-table-ref/default *host-loads* hostname #f))) + (if h + h + (let ((h (make-host))) + (hash-table-set! *host-loads* hostname h) + h)))) + (host-info (common:get-host-info hostname)) + (is-reachable (car host-info)) + (last-reached-time (cadr host-info)) + (load (caddr host-info))) + (host-reachable-set! rec is-reachable) + (host-last-update-set! rec last-reached-time) + (host-last-cpuload-set! rec load))) + hosts))) + +;; go through the hosts from least recently used to most recently used, pick the first that meets the load criteral from the +;; [host-rules] section. +;; +(define (common:get-least-loaded-host hosts-raw host-type configdat) + (let* ((rdat (configf:lookup configdat "host-rules" host-type)) + (rules (common:val->alist (or rdat "") convert: #t)) ;; maxnload, maxnjobs, maxjobrate + (maxnload (common:alist-ref/default 'maxnload rules 1.5)) ;; max normalized load + (maxnjobs (common:alist-ref/default 'maxnjobs rules 1.5)) ;; max normalized number of jobs + (maxjobrate (common:alist-ref/default 'maxjobrate rules (/ 1 6))) ;; max rate of submitting jobs to a given host in jobs/second + (hosts (filter (lambda (x) + (string-match (regexp "^\\S+$") x)) + hosts-raw)) + ;; (best-host #f) + (get-rec (lambda (hostname) + ;; (print "get-rec hostname=" hostname) + (let ((h (hash-table-ref/default *host-loads* hostname #f))) + (if h + h + (let ((h (make-host))) + (hash-table-set! *host-loads* hostname h) + h))))) + (best-load 99999) + (curr-time (current-seconds)) + (get-hosts-sorted (lambda (hosts) + (sort hosts (lambda (a b) + (let ((a-rec (get-rec a)) + (b-rec (get-rec b))) + ;; (print "a=" a " a-rec=" a-rec " host-last-used=" (host-last-used a-rec)) + ;; (print "b=" b " b-rec=" b-rec " host-last-used=" (host-last-used b-rec)) + (< (host-last-used a-rec) + (host-last-used b-rec)))))))) + (debug:print 0 *default-log-port* "INFO: hosts-sorted=" (get-hosts-sorted hosts)) + (if (null? hosts) + #f ;; no hosts to select from. All done and giving up now. + (let ((hosts-sorted (get-hosts-sorted hosts))) + (common:update-host-loads-table hosts) + (let loop ((hostname (car hosts-sorted)) + (tal (cdr hosts-sorted)) + (best-host #f)) + (let* ((rec (get-rec hostname)) + (reachable (host-reachable rec)) + (load (host-last-cpuload rec)) + (last-used (host-last-used rec)) + (delta (- curr-time last-used)) + (job-rate (if (> delta 0) + (/ 1 delta) + 999)) ;; jobs per second + (new-best + (cond + ((not reachable) + (debug:print 0 *default-log-port* "Skipping host " hostname " as it cannot be reached.") + best-host) + ((and (< load maxnload) ;; load is acceptable + (< job-rate maxjobrate)) ;; job rate is acceptable + (set! best-load load) + hostname) + (else best-host)))) + (debug:print 0 *default-log-port* "INFO: Trying host " hostname " with load " load ", last used " delta " seconds ago, with job-rate " job-rate " for running a test." ) + (if new-best + (begin ;; found a host, return it + (debug:print 0 *default-log-port* "INFO: Found host: " new-best " load: " load " last-used: " delta " seconds ago, with job-rate: " job-rate) + (host-last-used-set! rec curr-time) + new-best) + (if (null? tal) #f (loop (car tal)(cdr tal) best-host))))))))) + +(define (common:wait-for-homehost-load maxnormload msg) + (let* ((hh-dat (if (common:on-homehost?) ;; if we are on the homehost then pass in #f so the calls are local. + #f + (common:get-homehost))) + (hh (if hh-dat (car hh-dat) #f))) + (common:wait-for-normalized-load maxnormload msg hh))) + +(define *numcpus-cache* (make-hash-table)) +(define (common:get-num-cpus remote-host) + (let* ((actual-host (or remote-host (get-host-name)))) + ;; hosts had better not be changing the number of cpus too often! + (or (hash-table-ref/default *numcpus-cache* actual-host #f) + (let* ((numcpus (or (common:get-cached-info actual-host "num-cpus" age: (+ 2592000 (random 3600))) + (let* ((proc (lambda () + (let loop ((numcpu 0) + (inl (read-line))) + (if (eof-object? inl) + (if (> numcpu 0) + numcpu + #f) ;; if zero return #f so caller knows that things are not working + (loop (if (string-match "^processor\\s+:\\s+\\d+$" inl) + (+ numcpu 1) + numcpu) + (read-line)))))) + (result (if remote-host + (with-input-from-pipe + (conc "ssh " remote-host " cat /proc/cpuinfo") + proc) + (with-input-from-file "/proc/cpuinfo" proc)))) + (if (and (number? result) + (> result 0)) + (common:write-cached-info actual-host "num-cpus" result)) + result)))) + (hash-table-set! *numcpus-cache* actual-host numcpus) + numcpus)))) ;; wait for normalized cpu load to drop below maxload ;; -(define (common:wait-for-normalized-load maxload #!key (msg #f)) - (let ((num-cpus (common:get-num-cpus))) - (common:wait-for-cpuload maxload num-cpus 15 msg: msg))) +(define (common:wait-for-normalized-load maxnormload msg remote-host #!optional (rem-tries 5)) + (let ((num-cpus (common:get-num-cpus remote-host))) + (if num-cpus + (common:wait-for-cpuload maxnormload num-cpus 15 msg: msg remote-host: remote-host) + (begin + (thread-sleep! (random 60)) ;; we failed to get num cpus. wait a bit and try again + (if (> rem-tries 0) + (common:wait-for-normalized-load maxnormload msg remote-host (- rem-tries 1)) + #f))))) +;; DO NOT CALL THIS DIRECTLY. It is called from common:wait-for-normalized-load +;; count - count down to zero, at some point we'd give up if the load never drops +;; num-tries - count down to zero number tries to get numcpus +;; +(define (common:wait-for-cpuload maxnormload numcpus-in + #!key (count 1000) + (msg #f)(remote-host #f)(num-tries 5)) + (let* ((loadavg (common:get-cpu-load remote-host)) + ;; not possible to have zero. If we get 1, it's possible that we got the previous default, and we should check again + (numcpus (if (<= 1 numcpus-in) + (common:get-num-cpus remote-host) + numcpus-in)) + (first (car loadavg)) + (next (cadr loadavg)) + (adjmaxload (* maxnormload (max 1 numcpus))) ;; possible bug + ;; where numcpus + ;; (or could be + ;; maxload) is + ;; zero, crude + ;; fallback is to + ;; at least use 1 + ;; effective load accounts for load jumps, this should elminate all the first-next-avg, adjwait, load-jump-limit + ;; etc. + (effective-load (common:get-intercept first next)) + (recommended-delay (common:get-delay effective-load numcpus)) + (effective-host (or remote-host "localhost")) + (normalized-effective-load (/ effective-load numcpus)) + (will-wait (> normalized-effective-load maxnormload))) + (if (> recommended-delay 0) + (let* ((actual-delay (min recommended-delay 30))) + (if (common:low-noise-print 30 (conc (round actual-delay) "-safe-load")) + (debug:print-info 0 *default-log-port* "Load control, delaying " + actual-delay " seconds to maintain safe load. current normalized effective load is " + normalized-effective-load".")) + (thread-sleep! actual-delay))) + + (cond + ;; bad data, try again to get the data + ((not will-wait) + (if (common:low-noise-print 30 (conc (round normalized-effective-load) "-load-acceptable-" effective-host)) + (debug:print 0 *default-log-port* "Effective load on " effective-host " is acceptable at " effective-load " continuing."))) + ((and (< first 0) ;; this indicates the loadavg data is bad - machine may not be reachable + (> num-tries 0)) + (debug:print 0 *default-log-port* "WARNING: received bad data from get-cpu-load " + first ", we'll sleep 10s and try " num-tries " more times.") + (thread-sleep! 10) + (common:wait-for-cpuload maxnormload numcpus-in + count: count remote-host: remote-host num-tries: (- num-tries 1))) + ;; need to wait for load to drop + ((and will-wait ;; (> first adjmaxload) + (> count 0)) + (debug:print-info 0 *default-log-port* + "Delaying 15" ;; adjwait + " seconds due to normalized effective load " normalized-effective-load ;; first + " exceeding max of " adjmaxload + " on server " (or remote-host (get-host-name)) + " (normalized load-limit: " maxnormload ") " (if msg msg "")) + (thread-sleep! 15) ;; adjwait) + (common:wait-for-cpuload maxnormload numcpus count: (- count 1) msg: msg remote-host: remote-host) + ;; put the message here to indicate came out of waiting + (debug:print-info 1 *default-log-port* + "On host: " effective-host + ", effective load: " effective-load + ", numcpus: " numcpus + ", normalized effective load: " normalized-effective-load + )) + ;; overloaded and count expired (i.e. went to zero) + (else + (if (> num-tries 0) ;; should be "num-tries-left". + (if (common:low-noise-print 30 (conc (round effective-load) "-load-acceptable-" effective-host)) + (debug:print 0 *default-log-port* "Load on " effective-host " is acceptable at effective normalized load of " + effective-normalized-load " continuing.")) + (debug:print 0 *default-log-port* "Load on " effective-host ", " + first" could not be retrieved. Giving up and continuing.")))))) + +;; DO NOT CALL THIS DIRECTLY. It is called from common:wait-for-normalized-load +;; +;; (define (common:wait-for-cpuload maxload-in numcpus-in waitdelay #!key (count 1000) (msg #f)(remote-host #f)(force-maxload #f)(num-tries 5)) +;; (let* ((loadavg (common:get-cpu-load remote-host)) +;; (numcpus (if (<= 1 numcpus-in) ;; not possible to have zero. If we get 1, it's possible that we got the previous default, and we should check again +;; (common:get-num-cpus remote-host) +;; numcpus-in)) +;; (maxload (if force-maxload +;; maxload-in +;; (if (number? maxload-in) +;; (max maxload-in 0.5) +;; 0.5))) ;; so maxload must be greater than 0.5 for now BUG - FIXME? +;; (first (car loadavg)) +;; (next (cadr loadavg)) +;; (adjmaxload (* maxload (max 1 numcpus))) ;; possible bug where +;; ;; numcpus (or could be +;; ;; maxload) is zero, +;; ;; crude fallback is to +;; ;; at least use 1 +;; (loadjmp (- first (if (> next (* numcpus 0.7)) ;; could do something with average of first and next? +;; 0 +;; next))) ;; we will force a conservative calculation any time next is large. +;; (first-next-avg (/ (+ first next) 2)) +;; ;; add some randomness to the time to break any alignment +;; ;; where netbatch dumps many jobs to machines simultaneously +;; (adjwait (min (+ 300 (random 10)) (abs (* (+ (random 10) +;; (/ (- 1000 count) 10) +;; waitdelay) +;; (- first adjmaxload) )))) +;; (load-jump-limit (configf:lookup-number *configdat* "setup" "load-jump-limit")) +;; ;; effective load accounts for load jumps, this should elminate all the first-next-avg, adjwait, load-jump-limit +;; ;; etc. +;; (effective-load (common:get-intercept first next)) +;; (effective-host (or remote-host "localhost")) +;; (normalized-effective-load (/ effective-load numcpus)) +;; (will-wait (> normalized-effective-load maxload))) +;; +;; ;; let's let the user know once in a long while that load checking +;; ;; is happening but not constantly report it +;; #;(if (common:low-noise-print 30 (conc "cpuload" (or remote-host "localhost"))) ;; (> (random 100) 75) ;; about 25% of the time +;; (debug:print-info 1 *default-log-port* "Checking cpuload on " (or remote-host "localhost") ", maxload: " maxload +;; ", load: " first ", adjmaxload: " adjmaxload ", loadjmp: " loadjmp)) +;; +;; (debug:print-info 1 *default-log-port* +;; "On host: " effective-host +;; ", effective load: " effective-load +;; ", numcpus: " numcpus +;; ", normalized effective load: " normalized-effective-load +;; ) +;; +;; (cond +;; ;; bad data, try again to get the data +;; ((and (< first 0) ;; this indicates the loadavg data is bad - machine may not be reachable +;; (> num-tries 0)) +;; (debug:print 0 *default-log-port* "WARNING: received bad data from get-cpu-load " first ", we'll sleep 10s and try " num-tries " more times.") +;; (thread-sleep! 10) +;; (common:wait-for-cpuload maxload-in numcpus-in waitdelay +;; count: count remote-host: remote-host force-maxload: force-maxload num-tries: (- num-tries 1))) +;; ;; need to wait for load to drop +;; ((and will-wait ;; (> first adjmaxload) +;; (> count 0)) +;; (debug:print-info 0 *default-log-port* +;; "Delaying " 15 ;; adjwait +;; " seconds due to normalized effective load " normalized-effective-load ;; first +;; " exceeding max of " adjmaxload +;; " on server " (or remote-host (get-host-name)) +;; " (normalized load-limit: " maxload ") " (if msg msg "")) +;; (thread-sleep! 15) ;; adjwait) +;; (common:wait-for-cpuload maxload numcpus waitdelay count: (- count 1) msg: msg remote-host: remote-host)) +;; ((and (> loadjmp (cond +;; (load-jump-limit load-jump-limit) +;; ((> numcpus 8)(/ numcpus 2)) +;; ((> numcpus 4)(/ numcpus 1.2)) +;; (else 0.5))) +;; (> count 0)) +;; (debug:print-info 0 *default-log-port* "waiting " adjwait " seconds due to possible load jump " loadjmp ". " +;; (if msg msg "")) +;; (thread-sleep! adjwait) +;; (common:wait-for-cpuload maxload numcpus waitdelay count: (- count 1) msg: msg remote-host: remote-host)) +;; (else +;; (if (> num-tries 0) +;; (if (common:low-noise-print 30 (conc (round first) "-load-acceptable-" (or remote-host "localhost"))) +;; (debug:print 0 *default-log-port* "Load on " (or remote-host "localhost") " is acceptable at " first " continuing.")) +;; (debug:print 0 *default-log-port* "Load on " (or remote-host "localhost") ", "first" could not be retrieved. Giving up and continuing.")))))) +;; (define (get-uname . params) (let* ((uname-res (process:cmd-run->list (conc "uname " (if (null? params) "-a" (car params))))) (uname #f)) (if (null? (car uname-res)) "unknown" @@ -761,10 +2373,20 @@ (let ((res (read-line))) (if (string? res) (string->number res))))) (get-unix-df path))) +(define (get-free-inodes path) + (if (configf:lookup *configdat* "setup" "free-inodes-script") + (with-input-from-pipe + (conc (configf:lookup *configdat* "setup" "free-inodes-script") " " path) + (lambda () + (let ((res (read-line))) + (if (string? res) + (string->number res))))) + (get-unix-inodes path))) + (define (get-unix-df path) (let* ((df-results (process:cmd-run->list (conc "df " path))) (space-rx (regexp "([0-9]+)\\s+([0-9]+)%")) (freespc #f)) ;; (write df-results) @@ -775,30 +2397,51 @@ (if (number? newval) (set! freespc newval)))))) (car df-results)) freespc)) -;; check space in dbdir -;; returns: ok/not dbspace required-space -;; -(define (common:check-db-dir-space) - (let* ((dbdir (db:get-dbdir)) - (dbspace (if (directory? dbdir) - (get-df dbdir) - 0)) - (required (string->number - (or (configf:lookup *configdat* "setup" "dbdir-space-required") - "100000")))) +(define (get-unix-inodes path) + (let* ((df-results (process:cmd-run->list (conc "df -i " path))) + (space-rx (regexp "([0-9]+)\\s+([0-9]+)%")) + (freenodes 0)) ;; 0 is a better failsafe than #f here. + ;; (write df-results) + (for-each (lambda (l) + (let ((match (string-search space-rx l))) + (if match + (let ((newval (string->number (cadr match)))) + (if (number? newval) + (set! freenodes newval)))))) + (car df-results)) + freenodes)) + +(define (common:check-space-in-dir dirpath required) + (let* ((dbspace (if (directory? dirpath) + (get-df dirpath) + 0))) (list (> dbspace required) dbspace required - dbdir))) + dirpath))) +;; check space in dbdir and in megatest dir +;; returns: ok/not dbspace required-space +;; +(define (common:check-db-dir-space) + (let* ((required (string->number + ;; default is 1GB (or actually a billion bytes) This is the number of 1 kB blocks. + (or (configf:lookup *configdat* "setup" "dbdir-space-required") + "1000000"))) + (dbdir (common:get-db-tmp-area)) ;; (db:get-dbdir)) + (tdbspace (common:check-space-in-dir dbdir required)) + (mdbspace (common:check-space-in-dir *toppath* required))) + (sort (list tdbspace mdbspace) (lambda (a b) + (< (cadr a)(cadr b)))))) + ;; check available space in dbdir, exit if insufficient ;; (define (common:check-db-dir-and-exit-if-insufficient) - (let* ((spacedat (common:check-db-dir-space)) + (let* ((spacedat (car (common:check-db-dir-space))) ;; look only at worst for now (is-ok (car spacedat)) (dbspace (cadr spacedat)) (required (caddr spacedat)) (dbdir (cadddr spacedat))) (if (not is-ok) @@ -807,12 +2450,16 @@ (exit 1))))) ;; paths is list of lists ((name path) ... ) ;; (define (common:get-disk-with-most-free-space disks minsize) - (let ((best #f) - (bestsize 0)) + (let* ((best #f) + (bestsize 0) + (default-min-inodes-string "1000000") + (default-min-inodes (string->number default-min-inodes-string)) + (min-inodes (or (string->number (if (configf:lookup *configdat* "setup" "min_inodes") (configf:lookup *configdat* "setup" "min_inodes") default-min-inodes-string)) default-min-inodes))) + (for-each (lambda (disk-num) (let* ((dirpath (cadr (assoc disk-num disks))) (freespc (cond ((not (directory? dirpath)) @@ -826,41 +2473,146 @@ ((not (eq? (string-ref dirpath 0) #\/)) (if (common:low-noise-print 300 "disks not a proper path " disk-num) (debug:print 0 *default-log-port* "WARNING: disk " disk-num " at path \"" dirpath "\" is not a fully qualified path - ignoring it.")) -1) (else - (get-df dirpath))))) - (if (> freespc bestsize) + (get-df dirpath)))) + (free-inodes (cond + ((not (directory? dirpath)) + (if (common:low-noise-print 300 "disks not a dir " disk-num) + (debug:print 0 *default-log-port* "WARNING: disk " disk-num " at path \"" dirpath "\" is not a directory - ignoring it.")) + -1) + ((not (file-write-access? dirpath)) + (if (common:low-noise-print 300 "disks not writeable " disk-num) + (debug:print 0 *default-log-port* "WARNING: disk " disk-num " at path \"" dirpath "\" is not writeable - ignoring it.")) + -1) + ((not (eq? (string-ref dirpath 0) #\/)) + (if (common:low-noise-print 300 "disks not a proper path " disk-num) + (debug:print 0 *default-log-port* "WARNING: disk " disk-num " at path \"" dirpath "\" is not a fully qualified path - ignoring it.")) + -1) + (else + (get-free-inodes dirpath)))) + ;;(free-inodes (get-free-inodes dirpath)) + ) + (debug:print 2 *default-log-port* "INFO: disk " disk-num " path " dirpath " free space " freespc " free inodes " free-inodes) + (if (and (> freespc bestsize)(> free-inodes min-inodes )) (begin (set! best (cons disk-num dirpath)) - (set! bestsize freespc))))) + (set! bestsize freespc))) + ;;(print "Processing: " disk-num " bestsize: " bestsize " best: " best " freespc: " freespc " min-inodes: " min-inodes " free-inodes: " free-inodes) + )) (map car disks)) (if (and best (> bestsize minsize)) best #f))) ;; #f means no disk candidate found + +;; convert a spec string to a list of vectors #( rx action rx-string ) +(define (common:spec-string->list-of-specs spec-string actions) + (let ((spec-strings (string-split-fields "\\s*;\\s*" spec-string #:infix)) + (actions-regex (regexp (conc "^(.*)\\s+(" (string-intersperse (map conc actions) "|") ")")))) + (filter + (lambda (x) x) + (map (lambda (s) + (let ((m (string-match actions-regex s))) + (if m + (vector (regexp (cadr m))(string->symbol (caddr m))(cadr m)) + (begin + (debug:print 0 *default-log-port* "WARNING: Unrecognised rule \"" s "\" in clean-up specification.") + #f)))) + spec-strings)))) + +;; given a list of specs rx . rule and a file return the first matching rule +;; +(define (common:file-find-rule fname rules) ;; rule is vector #( rx action rx-string) + (let loop ((rule (car rules)) + (tail (cdr rules))) + (let ((rx (vector-ref rule 0)) + (rn (vector-ref rule 1))) ;; rule name + (if (string-match rx fname) + rule ;; return the whole rule so regex can be printed etc. + (if (null? tail) + #f + (loop (car tail)(cdr tail))))))) + +;; given a spec apply some rules to a directory +;; +;; WARNING: This function will REMOVE files - be sure your spec and path is correct! +;; +;; spec format: +;; file-regex1 action; file-regex2 action; ... +;; e.g. +;; .*\.log$ keep; .* remove +;; --> keep all .log files, remove everything else +;; limitations: +;; cannot have a rule with ; as part of the spec +;; not very flexible, would be nice to return binned file names? +;; supported rules: +;; keep - keep this file +;; remove - remove this file +;; compress - compress this file +;; +(define (common:dir-clean-up path spec-string #!key (compress "gzip")(actions '(keep remove compress))(remove-empty #f)) + (let* ((specs (common:spec-string->list-of-specs spec-string actions)) + (keepers (make-hash-table)) + (directories (make-hash-table))) + (find-files + path + action: (lambda (p res) + (let ((rule (common:file-find-rule p specs))) + (cond + ((directory? p)(hash-table-set! directories p #t)) + (else + (case (vector-ref rule 1) + ((keep)(hash-table-set! keepers p rule)) + ((remove) + (print "Removing file " p) + (delete-file p)) + ((compress) + (print "Compressing file " p) + (system (conc compress " " p))) + (else + (print "No match for file " p)))))))) + (if remove-empty + (for-each + (lambda (d) + (if (null? (glob (conc d "/.*")(conc d "/*"))) + (begin + (print "Removing empty directory " d) + (delete-directory d)))) + (sort (hash-table-keys directories) (lambda (a b)(> (string-length a)(string-length b)))))) + )) ;;====================================================================== ;; E N V I R O N M E N T V A R S ;;====================================================================== +(define (bb-check-path #!key (msg "check-path: ")) + (let ((path (or (get-environment-variable "PATH") "none"))) + (debug:print-info 0 *default-log-port* (conc msg" : $PATH="path)) + (if (string-match "^.*/isoenv-core/.*" path) + (debug:print-error 0 *default-log-port* (conc msg" : !!ISOENV PRESENT!!")) ;; remove for prod + (debug:print-info 1 *default-log-port* (conc msg" : **no isoenv present**"))))) + (define (save-environment-as-files fname #!key (ignorevars (list "USER" "HOME" "DISPLAY" "LS_COLORS" "XKEYSYMDB" "EDITOR" "MAKEFLAGS" "MAKEF" "MAKEOVERRIDES"))) + ;;(bb-check-path msg: "save-environment-as-files entry") (let ((envvars (get-environment-variables)) - (whitesp (regexp "[^a-zA-Z0-9_\\-:,.\\/%$]")) + (whitesp (regexp "[^a-zA-Z0-9_\\-:,\\.\\/%$]")) (mungeval (lambda (val) (cond ((eq? val #t) "") ;; convert #t to empty string ((eq? val #f) #f) ;; convert #f to itself (still thinking about this one (else val))))) - (with-output-to-file (conc fname ".csh") + (with-output-to-file (conc fname ".csh") (lambda () (for-each (lambda (keyval) (let* ((key (car keyval)) (val (cdr keyval)) (delim (if (string-search whitesp val) "\"" ""))) - (print (if (member key ignorevars) + (print (if (or (member key ignorevars) + (string-search whitesp key)) "# setenv " "setenv ") key " " delim (mungeval val) delim))) envvars))) (with-output-to-file (conc fname ".sh") @@ -869,37 +2621,86 @@ (let* ((key (car keyval)) (val (cdr keyval)) (delim (if (string-search whitesp val) "\"" ""))) - (print (if (member key ignorevars) + (print (if (or (member key ignorevars) + (string-search whitesp key) + (string-search ":" key)) ;; internal only values to be skipped. "# export " "export ") key "=" delim (mungeval val) delim))) envvars))))) + +(define (common:get-param-mapping #!key (flavor #f)) + "returns alist mapping string keys in testconfig/subrun to megatest command line switches; if flavor is switch-symbol, maps tcmt symbolic switches to megatest switches" + (let ((default '(("tag-expr" . "-tagexpr") + ("mode-patt" . "-modepatt") + ("run-name" . "-runname") + ("contour" . "-contour") + ("target" . "-target") + ("test-patt" . "-testpatt") + ("rerun" . "-rerun") + ("setvars" . "-setvars") + ("msg" . "-m") + ("log" . "-log") + ("start-dir" . "-start-dir") + ("new" . "-set-state-status")))) + (if (eq? flavor 'switch-symbol) + (map (lambda (x) + (cons (string->symbol (conc "-" (car x))) (cdr x))) + default) + default))) + ;; set some env vars from an alist, return an alist with original values ;; (("VAR" "value") ...) +;; a value of #f means "unset this var" +;; (define (alist->env-vars lst) (if (list? lst) (let ((res '())) (for-each (lambda (p) (let* ((var (car p)) (val (cadr p)) (prv (get-environment-variable var))) (set! res (cons (list var prv) res)) (if val - (setenv var (->string val)) + (safe-setenv var (->string val)) (unsetenv var)))) lst) res) '())) + ;; clear vars matching pattern, run proc, set vars back ;; if proc is a string run that string as a command with ;; system. ;; +(define *common:orig-env* + (let ((envvars (get-environment-variables))) + (if (get-environment-variable "MT_ORIG_ENV") + (with-input-from-string + (z3:decode-buffer (base64:base64-decode (get-environment-variable "MT_ORIG_ENV"))) + read) + (filter-map (lambda (x) + (if (string-match "^MT_.*" (car x)) + #f + x)) + envvars)))) + +(define (common:with-orig-env proc) + (let ((current-env (get-environment-variables))) + (for-each (lambda (x) (unsetenv (car x))) current-env) + (for-each (lambda (x) (setenv (car x) (cdr x))) *common:orig-env*) + (let ((rv (cond + ((string? proc)(system proc)) + (proc (proc))))) + (for-each (lambda (x) (unsetenv (car x))) *common:orig-env*) + (for-each (lambda (x) (setenv (car x) (cdr x))) current-env) + rv))) + (define (common:without-vars proc . var-patts) (let ((vars (make-hash-table))) (for-each (lambda (vardat) ;; each env var (for-each @@ -918,40 +2719,78 @@ vars (lambda (var val) (setenv var val))) vars)) -(define (common:run-a-command cmd) - (let ((fullcmd (conc (dtests:get-pre-command) - cmd - (dtests:get-post-command)))) +(define (common:propogate-mt-vars-to-subrun proc propogate-vars) + (let ((vars (make-hash-table)) + (var-patt "^MT_.*")) + (for-each + (lambda (vardat) ;; each env var + ;(for-each + ;(lambda (var-patt) + (if (string-match var-patt (car vardat)) + (let ((var (car vardat)) + (val (cdr vardat))) + (hash-table-set! vars var val) + (if (member var propogate-vars) + (begin + (print var " " (string-substitute "MT_" "PARENT_" var)) + (setenv (string-substitute "MT_" "PARENT_" var) val))) + (unsetenv var)))) +; var-patts)) + (get-environment-variables)) + (cond + ((string? proc)(system proc)) + (proc (proc))) + (hash-table-for-each + vars + (lambda (var val) + (if (member var propogate-vars) + (unsetenv (string-substitute "MT_" "PARENT_" var))) + (setenv var val))) + vars)) + + +(define (common:run-a-command cmd #!key (with-vars #f) (with-orig-env #f)) + (let* ((pre-cmd (dtests:get-pre-command)) + (post-cmd (dtests:get-post-command)) + (fullcmd (if (or pre-cmd post-cmd) + (conc pre-cmd cmd post-cmd) + (conc "viewscreen " cmd)))) (debug:print-info 02 *default-log-port* "Running command: " fullcmd) - (common:without-vars fullcmd "MT_.*"))) + (cond + (with-vars (common:without-vars fullcmd)) + (with-orig-env (common:with-orig-env fullcmd)) + (else (common:without-vars fullcmd "MT_.*"))))) ;;====================================================================== ;; T I M E A N D D A T E ;;====================================================================== ;; Convert strings like "5s 2h 3m" => 60x60x2 + 3x60 + 5 (define (common:hms-string->seconds tstr) - (let ((parts (string-split tstr)) + (let ((parts (string-split-fields "\\w+" tstr)) (time-secs 0) - ;; s=seconds, m=minutes, h=hours, d=days - (trx (regexp "(\\d+)([smhd])"))) + ;; s=seconds, m=minutes, h=hours, d=days, M=months, y=years, w=weeks + (trx (regexp "(\\d+)([smhdMyw])"))) (for-each (lambda (part) (let ((match (string-match trx part))) (if match (let ((val (string->number (cadr match))) (unt (caddr match))) (if val (set! time-secs (+ time-secs (* val (case (string->symbol unt) ((s) 1) - ((m) 60) - ((h) (* 60 60)) - ((d) (* 24 60 60)) - (else 0)))))))))) + ((m) 60) ;; minutes + ((h) 3600) + ((d) 86400) + ((w) 604800) + ((M) 2628000) ;; aproximately one month + ((y) 31536000) + (else #f)))))))))) parts) time-secs)) (define (seconds->hr-min-sec secs) (let* ((hrs (quotient secs 3600)) @@ -994,10 +2833,15 @@ ((4 5 6) 2) ((7 8 9) 3) ((10 11 12) 4) (else #f))) +;; basic ISO8601 format (e.g. "2017-02-28 06:02:54") date time => Unix epoch +;; +(define (common:date-time->seconds datetime) + (local-time->seconds (string->time datetime "%Y-%m-%d %H:%M:%S"))) + ;; given span of seconds tstart to tend ;; find start time to mark and mark delta ;; (define (common:find-start-mark-and-mark-delta tstart tend) (let* ((deltat (- (max tend (+ tend 10)) tstart)) ;; can't handle runs of less than 4 seconds. Pad it to 10 seconds ... @@ -1027,12 +2871,175 @@ (list 8 6 5 2 1))) '(5 10 15 20 30 40 50 500)) (if values (apply values result) (values 0 day 1 0 'd)))) + +;; given x y lim return the cron expansion +;; +(define (common:expand-cron-slash x y lim) + (let loop ((curr x) + (res `())) + (if (< curr lim) + (loop (+ curr y) (cons curr res)) + (reverse res)))) + +;; expand a complex cron string to a list of cron strings +;; +;; x/y => x, x+y, x+2y, x+3y while x+Ny a, b ,c +;; +;; NOTE: with flatten a lot of the crud below can be factored down. +;; +(define (common:cron-expand cron-str) + (if (list? cron-str) + (flatten + (fold (lambda (x res) + (if (list? x) + (let ((newres (map common:cron-expand x))) + (append x newres)) + (cons x res))) + '() + cron-str)) ;; (map common:cron-expand cron-str)) + (let ((cron-items (string-split cron-str)) + (slash-rx (regexp "(\\d+)/(\\d+)")) + (comma-rx (regexp ".*,.*")) + (max-vals '((min . 60) + (hour . 24) + (dayofmonth . 28) ;;; BUG!!!! This will be a bug for some combinations + (month . 12) + (dayofweek . 7)))) + (if (< (length cron-items) 5) ;; bad spec + cron-str ;; `(,cron-str) ;; just return the string, something downstream will fix it + (let loop ((hed (car cron-items)) + (tal (cdr cron-items)) + (type 'min) + (type-tal '(hour dayofmonth month dayofweek)) + (res '())) + (regex-case + hed + (slash-rx ( _ base incr ) (let* ((basen (string->number base)) + (incrn (string->number incr)) + (expanded-vals (common:expand-cron-slash basen incrn (alist-ref type max-vals))) + (new-list-crons (fold (lambda (x myres) + (cons (conc (if (null? res) + "" + (conc (string-intersperse res " ") " ")) + x " " (string-intersperse tal " ")) + myres)) + '() expanded-vals))) + ;; (print "new-list-crons: " new-list-crons) + ;; (fold (lambda (x res) + ;; (if (list? x) + ;; (let ((newres (map common:cron-expand x))) + ;; (append x newres)) + ;; (cons x res))) + ;; '() + (flatten (map common:cron-expand new-list-crons)))) + ;; (map common:cron-expand (map common:cron-expand new-list-crons)))) + (else (if (null? tal) + cron-str + (loop (car tal)(cdr tal)(car type-tal)(cdr type-tal)(append res (list hed))))))))))) + - +;; given a cron string and the last time event was processed return #t to run or #f to not run +;; +;; min hour dayofmonth month dayofweek +;; 0-59 0-23 1-31 1-12 0-6 ### NOTE: dayofweek does not include 7 +;; +;; #t => yes, run the job +;; #f => no, do not run the job +;; +(define (common:cron-event cron-str now-seconds-in last-done) ;; ref-seconds = #f is NOW. + (let* ((cron-items (map string->number (string-split cron-str))) + (now-seconds (or now-seconds-in (current-seconds))) + (now-time (seconds->local-time now-seconds)) + (last-done-time (seconds->local-time last-done)) + (all-times (make-hash-table))) + ;; (print "cron-items: " cron-items "(length cron-items): " (length cron-items)) + (if (not (eq? (length cron-items) 5)) ;; don't even try to figure out junk strings + #f + (match-let ((( cmin chour cdayofmonth cmonth cdayofweek) + cron-items) + ;; 0 1 2 3 4 5 6 + ((nsec nmin nhour ndayofmonth nmonth nyr ndayofweek n7 n8 n9) + (vector->list now-time)) + ((lsec lmin lhour ldayofmonth lmonth lyr ldayofweek l7 l8 l9) + (vector->list last-done-time))) + ;; create all possible time slots + ;; remove invalid slots due to (for example) day of week + ;; get the start and end entries for the ref-seconds (current) time + ;; if last-done > ref-seconds => this is an ERROR! + ;; does the last-done time fall in the legit region? + ;; yes => #f do not run again this command + ;; no => #t ok to run the command + (for-each ;; month + (lambda (month) + (for-each ;; dayofmonth + (lambda (dom) + (for-each + (lambda (hr) ;; hour + (for-each + (lambda (minute) ;; minute + (let ((copy-now (apply vector (vector->list now-time)))) + (vector-set! copy-now 0 0) ;; force seconds to zero + (vector-set! copy-now 1 minute) + (vector-set! copy-now 2 hr) + (vector-set! copy-now 3 dom) ;; dom is already corrected for zero referenced + (vector-set! copy-now 4 month) + (let* ((copy-now-secs (local-time->seconds copy-now)) + (new-copy (seconds->local-time copy-now-secs))) ;; remake the time vector + (if (or (not cdayofweek) + (equal? (vector-ref new-copy 6) + cdayofweek)) ;; if the day is specified and a match OR if the day is NOT specified + (if (or (not cdayofmonth) + (equal? (vector-ref new-copy 3) + (+ 1 cdayofmonth))) ;; if the month is specified and a match OR if the month is NOT specified + (hash-table-set! all-times copy-now-secs new-copy)))))) + (if cmin + `(,cmin) ;; if given cmin, have to use it + (list (- nmin 1) nmin (+ nmin 1))))) ;; minute + (if chour + `(,chour) + (list (- nhour 1) nhour (+ nhour 1))))) ;; hour + (if cdayofmonth + `(,cdayofmonth) + (list (- ndayofmonth 1) ndayofmonth (+ ndayofmonth 1))))) + (if cmonth + `(,cmonth) + (list (- nmonth 1) nmonth (+ nmonth 1)))) + (let ((before #f) + (is-in #f)) + (for-each + (lambda (moment) + (if (and before + (<= before now-seconds) + (>= moment now-seconds)) + (begin + ;; (print) + ;; (print "Before: " (time->string (seconds->local-time before))) + ;; (print "Now: " (time->string (seconds->local-time now-seconds))) + ;; (print "After: " (time->string (seconds->local-time moment))) + ;; (print "Last: " (time->string (seconds->local-time last-done))) + (if (< last-done before) + (set! is-in before)) + )) + (set! before moment)) + (sort (hash-table-keys all-times) <)) + is-in))))) + +(define (common:extended-cron cron-str now-seconds-in last-done) + (let ((expanded-cron (common:cron-expand cron-str))) + (if (string? expanded-cron) + (common:cron-event expanded-cron now-seconds-in last-done) + (let loop ((hed (car expanded-cron)) + (tal (cdr expanded-cron))) + (if (common:cron-event hed now-seconds-in last-done) + #t + (if (null? tal) + #f + (loop (car tal)(cdr tal)))))))) ;;====================================================================== ;; C O L O R S ;;====================================================================== @@ -1058,10 +3065,62 @@ ;; ((KILLREQ) "39 82 206") ;; ((KILLED) "234 101 17") ;; ((NOT_STARTED) "240 240 240") ;; (else "192 192 192"))) +(define (common:iup-color->rgb-hex instr) + (string-intersperse + (map (lambda (x) + (number->string x 16)) + (map string->number + (string-split instr))) + "/")) + +;;====================================================================== +;; L O C K I N G M E C H A N I S M S +;;====================================================================== + +;; faux-lock is deprecated. Please use simple-lock below +;; +(define (common:faux-lock keyname #!key (wait-time 8)(allow-lock-steal #t)) + (if (rmt:no-sync-get/default keyname #f) ;; do not be tempted to compare to pid. locking is a one-shot action, if already locked for this pid it doesn't actually count + (if (> wait-time 0) + (begin + (thread-sleep! 1) + (if (eq? wait-time 1) ;; only one second left, steal the lock + (begin + (debug:print-info 0 *default-log-port* "stealing lock for " keyname) + (common:faux-unlock keyname force: #t))) + (common:faux-lock keyname wait-time: (- wait-time 1))) + #f) + (begin + (rmt:no-sync-set keyname (conc (current-process-id))) + (equal? (conc (current-process-id)) (conc (rmt:no-sync-get/default keyname #f)))))) + +(define (common:faux-unlock keyname #!key (force #f)) + (if (or force (equal? (conc (current-process-id)) (conc (rmt:no-sync-get/default keyname #f)))) + (begin + (if (rmt:no-sync-get/default keyname #f) (rmt:no-sync-del! keyname)) + #t) + #f)) + +;; simple lock. improve and converge on this one. +;; +(define (common:simple-lock keyname) + (rmt:no-sync-get-lock keyname)) + +(define (common:simple-unlock keyname #!key (force #f)) + (rmt:no-sync-del! keyname)) + + +;;====================================================================== +;; +;;====================================================================== + +(define (common:in-running-test?) + (and (args:get-arg "-execute") (get-environment-variable "MT_CMDINFO"))) + (define (common:get-color-from-status status) (cond ((equal? status "PASS") "green") ((equal? status "FAIL") "red") ((equal? status "WARN") "orange") @@ -1069,209 +3128,121 @@ ((equal? status "KILLREQ") "purple") ((equal? status "RUNNING") "blue") ((equal? status "ABORT") "brown") (else "black"))) -;;====================================================================== -;; N A N O M S G C L I E N T -;;====================================================================== - -(define (server:get-best-guess-address hostname) - (let ((res #f)) - (for-each - (lambda (adr) - (if (not (eq? (u8vector-ref adr 0) 127)) - (set! res adr))) - ;; NOTE: This can fail when there is no mention of the host in /etc/hosts. FIXME - (vector->list (hostinfo-addresses (hostname->hostinfo hostname)))) - (string-intersperse - (map number->string - (u8vector->list - (if res res (hostname->ip hostname)))) "."))) - -(define (common:open-nm-req addr) - (let* ((req (nn-socket 'req)) - (res (nn-connect req addr))) - req)) - -;; (with-output-to-string (lambda ()(serialize obj))) -(define (common:nm-send-receive soc msg) - (nn-send soc msg) - (nn-recv soc)) - -(define (common:close-nm-req soc) - (nn-close soc)) - -(define (common:send-dboard-main-changed) - (let* ((dashboard-ips (mddb:get-dashboards))) - (for-each - (lambda (ipadr) - (let* ((soc (common:open-nm-req (conc "tcp://" ipadr))) - (msg (conc "main " *toppath*)) - (res (common:nm-send-receive-timeout soc msg))) - (if (not res) ;; couldn't reach that dashboard - remove it from db - (print "ERROR: couldn't reach dashboard " ipadr)) - res)) - dashboard-ips))) - -(define (common:nm-send-receive-timeout req msg) - (let* ((key "ping") - (success #f) - (keepwaiting #t) - (result #f) - (sendrec (make-thread - (lambda () - (nn-send req msg) - (set! result (nn-recv req)) - (set! success #t)) - "send-receive")) - (timeout (make-thread (lambda () - (let loop ((count 0)) - (thread-sleep! 1) - (print "still waiting after count seconds...") - (if (and keepwaiting (< count 10)) - (loop (+ count 1)))) - (if keepwaiting - (begin - (print "timeout waiting for reply") - (thread-terminate! sendrec)))) - "timeout"))) - (handle-exceptions - exn - (begin - (print-call-chain) - (print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) - (print "exn=" (condition->list exn))) - (thread-start! timeout) - (thread-start! sendrec) - (thread-join! sendrec) - (if success (thread-terminate! timeout))) - result)) - -(define (common:ping-nm req) - ;; send a random number and check that we get it back - (let* ((key "ping") - (success #f) - (keepwaiting #t) - (ping (make-thread - (lambda () - (print "ping: sending string \"" key "\", expecting " (current-process-id)) - (nn-send req key) - (let ((result (nn-recv req))) - (if (equal? (conc (current-process-id)) result) - (begin - (print "ping, success: received \"" result "\"") - (set! success #t)) - (begin - (print "ping, failed: received key \"" result "\"") - (set! keepwaiting #f) - (set! success #f))))) - "ping")) - (timeout (make-thread (lambda () - (let loop ((count 0)) - (thread-sleep! 1) - (print "still waiting after count seconds...") - (if (and keepwaiting (< count 10)) - (loop (+ count 1)))) - (if keepwaiting - (begin - (print "timeout waiting for ping") - (thread-terminate! ping)))) - "timeout"))) - (handle-exceptions - exn - (begin - (print-call-chain) - (print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) - (print "exn=" (condition->list exn)) - (print "ping failed to connect to tcp://" hostport)) - (thread-start! timeout) - (thread-start! ping) - (thread-join! ping) - (if success (thread-terminate! timeout))) - (if return-socket - (if success req #f) - (begin - (nn-close req) - success)))) - -;;====================================================================== -;; D A S H B O A R D D B -;;====================================================================== - -(define (mddb:open-db) - (let* ((db (open-database (conc (get-environment-variable "HOME") "/.dashboard.db")))) - (set-busy-handler! db (busy-timeout 10000)) - (for-each - (lambda (qry) - (exec (sql db qry))) - (list - "CREATE TABLE IF NOT EXISTS vars (id INTEGER PRIMARY KEY,key TEXT, val TEXT, CONSTRAINT varsconstraint UNIQUE (key));" - "CREATE TABLE IF NOT EXISTS dashboards ( - id INTEGER PRIMARY KEY, - pid INTEGER, - username TEXT, - hostname TEXT, - ipaddr TEXT, - portnum INTEGER, - start_time TIMESTAMP DEFAULT (strftime('%s','now')), - CONSTRAINT hostport UNIQUE (hostname,portnum) - );" - )) - db)) - -;; register a dashboard -;; -(define (mddb:register-dashboard port) - (let* ((pid (current-process-id)) - (hostname (get-host-name)) - (ipaddr (server:get-best-guess-address hostname)) - (username (current-user-name)) ;; (car userinfo))) - (db (mddb:open-db))) - (print "Register monitor, pid: " pid ", hostname: " hostname ", port: " port ", username: " username) - (exec (sql db "INSERT OR REPLACE INTO dashboards (pid,username,hostname,ipaddr,portnum) VALUES (?,?,?,?,?);") - pid username hostname ipaddr port) - (close-database db))) - -;; unregister a monitor -;; -(define (mddb:unregister-dashboard host port) - (let* ((db (mddb:open-db))) - (print "Register unregister monitor, host:port=" host ":" port) - (exec (sql db "DELETE FROM dashboards WHERE hostname=? AND portnum=?;") host port) - (close-database db))) - -;; get registered dashboards -;; -(define (mddb:get-dashboards) - (let ((db (mddb:open-db))) - (query fetch-column - (sql db "SELECT ipaddr || ':' || portnum FROM dashboards;")))) +;; ;;====================================================================== +;; ;; N A N O M S G C L I E N T +;; ;;====================================================================== +;; +;; +;; +;; (define (common:send-dboard-main-changed) +;; (let* ((dashboard-ips (mddb:get-dashboards))) +;; (for-each +;; (lambda (ipadr) +;; (let* ((soc (common:open-nm-req (conc "tcp://" ipadr))) +;; (msg (conc "main " *toppath*)) +;; (res (common:nm-send-receive-timeout soc msg))) +;; (if (not res) ;; couldn't reach that dashboard - remove it from db +;; (print "ERROR: couldn't reach dashboard " ipadr)) +;; res)) +;; dashboard-ips))) +;; +;; +;; ;;====================================================================== +;; ;; D A S H B O A R D D B +;; ;;====================================================================== +;; +;; (define (mddb:open-db) +;; (let* ((db (open-database (conc (get-environment-variable "HOME") "/.dashboard.db")))) +;; (set-busy-handler! db (busy-timeout 10000)) +;; (for-each +;; (lambda (qry) +;; (exec (sql db qry))) +;; (list +;; "CREATE TABLE IF NOT EXISTS vars (id INTEGER PRIMARY KEY,key TEXT, val TEXT, CONSTRAINT varsconstraint UNIQUE (key));" +;; "CREATE TABLE IF NOT EXISTS dashboards ( +;; id INTEGER PRIMARY KEY, +;; pid INTEGER, +;; username TEXT, +;; hostname TEXT, +;; ipaddr TEXT, +;; portnum INTEGER, +;; start_time TIMESTAMP DEFAULT (strftime('%s','now')), +;; CONSTRAINT hostport UNIQUE (hostname,portnum) +;; );" +;; )) +;; db)) +;; +;; ;; register a dashboard +;; ;; +;; (define (mddb:register-dashboard port) +;; (let* ((pid (current-process-id)) +;; (hostname (get-host-name)) +;; (ipaddr (server:get-best-guess-address hostname)) +;; (username (current-user-name)) ;; (car userinfo))) +;; (db (mddb:open-db))) +;; (print "Register monitor, pid: " pid ", hostname: " hostname ", port: " port ", username: " username) +;; (exec (sql db "INSERT OR REPLACE INTO dashboards (pid,username,hostname,ipaddr,portnum) VALUES (?,?,?,?,?);") +;; pid username hostname ipaddr port) +;; (close-database db))) +;; +;; ;; unregister a monitor +;; ;; +;; (define (mddb:unregister-dashboard host port) +;; (let* ((db (mddb:open-db))) +;; (print "Register unregister monitor, host:port=" host ":" port) +;; (exec (sql db "DELETE FROM dashboards WHERE hostname=? AND portnum=?;") host port) +;; (close-database db))) +;; +;; ;; get registered dashboards +;; ;; +;; (define (mddb:get-dashboards) +;; (let ((db (mddb:open-db))) +;; (query fetch-column +;; (sql db "SELECT ipaddr || ':' || portnum FROM dashboards;")))) ;;====================================================================== ;; T E S T L A U N C H I N G P E R I T E M W I T H H O S T T Y P E S ;;====================================================================== ;; -;; [host-types] -;; general ssh #{getbgesthost general} -;; nbgeneral nbjob run JOBCOMMAND -log $MT_LINKTREE/$MT_TARGET/$MT_RUNNAME.$MT_TESTNAME-$MT_ITEM_PATH.lgo +;; [hosts] +;; arm cubie01 cubie02 +;; x86_64 zeus xena myth01 +;; allhosts #{g hosts arm} #{g hosts x86_64} ;; -;; [hosts] -;; general cubian xena +;; [host-types] +;; C/M/A lets megatest know this launcher provides C cores, M bytes memory for architecture A +;; 2/2G/arm smart -cores 2 -memory 2G -arch arm +;; general #MTLOWESTLOAD #{g hosts allhosts} +;; arm #MTLOWESTLOAD #{g hosts arm} +;; nbgeneral nbjob run JOBCOMMAND -log $MT_LINKTREE/$MT_TARGET/$MT_RUNNAME.$MT_TESTNAME-$MT_ITEM_PATH.lgo +;; +;; NOTE: host-rules is ONLY used for MTLOWESTLOAD +;; +;; [host-rules] +;; # maxnload => max normalized load +;; # maxnjobs => max jobs per cpu +;; # maxjobrate => max jobs per second +;; general maxnload=1.1; maxnjobs=1.2; maxjobrate=0.1 ;; ;; [launchers] ;; envsetup general -;; xor/%/n 4C16G +;; xor/%/n 2/2G/arm ;; % nbgeneral ;; ;; [jobtools] -;; launcher bsub -;; # if defined and not "no" flexi-launcher will bypass launcher unless there is no -;; # match. +;; # if defined and not "no" flexi-launcher will bypass "launcher" unless no match. ;; flexi-launcher yes - -(define (common:get-launcher configdat testname itempath) +;; launcher nbfake +;; mode adjutant|normal (default is normal) +;; +;; +;; mode is 'normal (i.e. directly use launcher) or 'adjutant (i.e. use adjutant) +;; +(define (common:get-launcher configdat testname itempath mode) (let ((fallback-launcher (configf:lookup configdat "jobtools" "launcher"))) (if (and (configf:lookup configdat "jobtools" "flexi-launcher") ;; overrides launcher (not (equal? (configf:lookup configdat "jobtools" "flexi-launcher") "no"))) (let* ((launchers (hash-table-ref/default configdat "launchers" '()))) (if (null? launchers) @@ -1278,16 +3249,36 @@ fallback-launcher (let loop ((hed (car launchers)) (tal (cdr launchers))) (let ((patt (car hed)) (host-type (cadr hed))) - (if (tests:match patt testname itempath) + (if (tests:match patt testname itempath) ;; have a launcher match for this test (begin (debug:print-info 2 *default-log-port* "Have flexi-launcher match for " testname "/" itempath " = " host-type) - (let ((launcher (configf:lookup configdat "host-types" host-type))) + (let ((launcher (configf:lookup configdat "host-types" host-type))) ;; find the actual launcher from the host-types table + ;; if we are in adjutant mode then we want to return both host-type and launcher (if launcher - launcher + (let* ((launcher-parts (string-split launcher)) + (launcher-exe (car launcher-parts))) + (if (equal? launcher-exe "#MTLOWESTLOAD") ;; this is our special case, we will find the lowest load and craft a nbfake commandline + (let host-loop ((targ-host (common:get-least-loaded-host (cdr launcher-parts) host-type configdat)) + (count 100)) + (if targ-host + (conc "remrun " targ-host) + (if (> count 0) + + (begin + (debug:print 0 *default-log-port* "INFO: Waiting for a host for host-type " host-type) + (thread-sleep! (- 101 count)) + (host-loop (common:get-least-loaded-host (cdr launcher-parts) host-type configdat) + (- count 1))) + (begin + (debug:print 0 *default-log-port* "FATAL: Failed to find a host from #MTLOWESTLOAD for host-type " host-type) + (exit))))) + (case mode + ((adjutant) (list host-type launcher)) + (else launcher)))) (begin (debug:print-info 0 *default-log-port* "WARNING: no launcher found for host-type " host-type) (if (null? tal) fallback-launcher (loop (car tal)(cdr tal))))))) @@ -1294,11 +3285,49 @@ ;; no match, try again (if (null? tal) fallback-launcher (loop (car tal)(cdr tal)))))))) fallback-launcher))) - + +;;====================================================================== +;; NMSG AND NEW API +;;====================================================================== + +;; nm based server experiment, keep around for now. +;; +(define (nm:start-server dbconn #!key (given-host-name #f)) + (let* ((srvdat (start-raw-server given-host-name: given-host-name)) + (host-name (srvdat-host srvdat)) + (soc (srvdat-soc srvdat))) + + ;; start the queue processor (save for second round of development) + ;; + (thread-start! (make-thread! (lambda ()(queue-processor dbconn) "Queue processor"))) + ;; msg is an alist + ;; 'r host:port <== where to return the data + ;; 'p params <== data to apply the command to + ;; 'e j|s|l <== encoding of the params. default is s (sexp), if not specified is assumed to be default + ;; 'c command <== look up the function to call using this key + ;; + (let loop ((msg-in (nn-recv soc))) + (if (not (equal? msg-in "quit")) + (let* ((dat (decode msg-in)) + (host-port (alist-ref 'r dat)) ;; this is for the reverse req rep where the server is a client of the original client + (params (alist-ref 'p dat)) + (command (let ((c (alist-ref 'c dat)))(if c (string->symbol c) #f))) + (all-good (and host-port params command (hash-table-exists? *commands* command)))) + (if all-good + (let ((cmddat (make-qitem + command: command + host-port: host-port + params: params))) + (queue-push cmddat) ;; put request into the queue + (nn-send soc "queued")) ;; reply with "queued" + (print "ERROR: ["(common:human-time)"] BAD request " dat)) + (loop (nn-recv soc))))) + (nn-close soc))) + ;;====================================================================== ;; D A S H B O A R D U S E R V I E W S ;;====================================================================== ;; first read ~/views.config if it exists, then read $MTRAH/views.config if it exists @@ -1305,12 +3334,332 @@ ;; (define (common:load-views-config) (let* ((view-cfgdat (make-hash-table)) (home-cfgfile (conc (get-environment-variable "HOME") "/.mtviews.config")) (mthome-cfgfile (conc *toppath* "/.mtviews.config"))) - (if (file-exists? mthome-cfgfile) + (if (common:file-exists? mthome-cfgfile) (read-config mthome-cfgfile view-cfgdat #t)) ;; we load the home dir file AFTER the MTRAH file so the user can clobber settings when running the dashboard in read-only areas - (if (file-exists? home-cfgfile) + (if (common:file-exists? home-cfgfile) (read-config home-cfgfile view-cfgdat #t)) view-cfgdat)) + +;;====================================================================== +;; H I E R A R C H I C A L H A S H T A B L E S +;;====================================================================== + +;; Every element including top element is a vector: +;; + +(define (hh:make-hh #!key (ht #f)(value #f)) + (vector (or ht (make-hash-table)) value)) + +;; used internally +(define-inline (hh:set-ht! hh ht) (vector-set! hh 0 ht)) +(define-inline (hh:get-ht hh) (vector-ref hh 0)) +(define-inline (hh:set-value! hh value) (vector-set! hh 1 value)) +(define-inline (hh:get-value hh value) (vector-ref hh 1)) + +;; given a hierarchial hash and some keys look up the value ... +;; +(define (hh:get hh . keys) + (if (null? keys) + (vector-ref hh 1) ;; we have reached the end of the line, return the value sought + (let ((sub-ht (hh:get-ht hh))) + (if sub-ht ;; yes, there is more hierarchy + (let ((sub-hh (hash-table-ref/default sub-ht (car keys) #f))) + (if sub-hh + (apply hh:get sub-hh (cdr keys)) + #f)) + #f)))) + +;; given a hierarchial hash, a value and some keys, add needed hierarcy and insert the value +;; +(define (hh:set! hh value . keys) + (if (null? keys) + (hh:set-value! hh value) ;; we have reached the end of the line, store the value + (let ((sub-ht (hh:get-ht hh))) + (if sub-ht ;; yes, there is more hierarchy + (let ((sub-hh (hash-table-ref/default sub-ht (car keys) #f))) + (if (not sub-hh) ;; we'll need to add the next level of hierarchy + (let ((new-sub-hh (hh:make-hh))) + (hash-table-set! sub-ht (car keys) new-sub-hh) + (apply hh:set! new-sub-hh value (cdr keys))) + (apply hh:set! sub-hh value (cdr keys)))) ;; call the sub-hierhash with remaining keys + (begin + (hh:set-ht! hh (make-hash-table)) + (apply hh:set! hh value keys)))))) + +;; Manage pkts, used in servers, tests and likely other contexts so put +;; in common +;;====================================================================== + +(define common:pkts-spec + '((default . ((parent . P) + (action . a) + (filename . f))) + (configf . ((parent . P) + (action . a) + (filename . f))) + (server . ((action . a) + (pid . d) + (ipaddr . i) + (port . p) + (parent . P))) + + (test . ((cpuuse . c) + (diskuse . d) + (item-path . i) + (runname . r) + (state . s) + (target . t) + (status . u) + (parent . P))))) + +(define (common:get-pkts-dirs mtconf use-lt) + (let* ((pktsdirs-str (or (configf:lookup mtconf "setup" "pktsdirs") + (and use-lt + (conc (or *toppath* + (current-directory)) + "/lt/.pkts")))) + (pktsdirs (if pktsdirs-str + (string-split pktsdirs-str " ") + #f))) + pktsdirs)) + +;; use-lt is use linktree "lt" link to find pkts dir +(define (common:save-pkt pktalist-in mtconf use-lt #!key (add-only #f)) ;; add-only saves the pkt only if there is a parent already + (if (or add-only + (hash-table-exists? *pkts-info* 'last-parent)) + (let* ((parent (hash-table-ref/default *pkts-info* 'last-parent #f)) + (pktalist (if parent + (cons `(parent . ,parent) + pktalist-in) + pktalist-in))) + (let-values (((uuid pkt) + (alist->pkt pktalist common:pkts-spec))) + (hash-table-set! *pkts-info* 'last-parent uuid) + (let ((pktsdir (or (hash-table-ref/default *pkts-info* 'pkts-dir #f) + (let* ((pktsdirs (common:get-pkts-dirs mtconf use-lt)) + (pktsdir (car pktsdirs))) ;; assume it is there + (hash-table-set! *pkts-info* 'pkts-dir pktsdir) + pktsdir)))) + (handle-exceptions + exn + (debug:print-info 0 "failed to write out packet to " pktsdir ", exn=" exn) ;; don't care if this failed for now but MUST FIX - BUG!! + (if (not (file-exists? pktsdir)) + (create-directory pktsdir #t)) + (with-output-to-file + (conc pktsdir "/" uuid ".pkt") + (lambda () + (print pkt))))))))) + +(define (common:with-queue-db mtconf proc #!key (use-lt #f)(toppath-in #f)) + (let* ((pktsdirs (common:get-pkts-dirs mtconf use-lt)) + (pktsdir (if pktsdirs (car pktsdirs) #f)) + (toppath (or (configf:lookup mtconf "scratchdat" "toppath") + toppath-in)) + (pdbpath (or (configf:lookup mtconf "setup" "pdbpath") pktsdir))) + (cond + ((not (and pktsdir toppath pdbpath)) + (debug:print 0 *default-log-port* "ERROR: settings are missing in your megatest.config for area management.") + (debug:print 0 *default-log-port* " you need to have pktsdirs in the [setup] section.")) + ((not (common:file-exists? pktsdir)) + (debug:print 0 *default-log-port* "ERROR: pkts directory not found " pktsdir)) + ((not (equal? (file-owner pktsdir)(current-effective-user-id))) + (debug:print 0 *default-log-port* "ERROR: directory " pktsdir " is not owned by " (current-effective-user-name))) + (else + (let* ((pdb (open-queue-db pdbpath "pkts.db" + schema: '("CREATE TABLE groups (id INTEGER PRIMARY KEY,groupname TEXT, CONSTRAINT group_constraint UNIQUE (groupname));")))) + (proc pktsdirs pktsdir pdb) + (dbi:close pdb)))))) + +(define (common:load-pkts-to-db mtconf #!key (use-lt #f)) + (common:with-queue-db + mtconf + (lambda (pktsdirs pktsdir pdb) + (for-each + (lambda (pktsdir) ;; look at all + (cond + ((not (common:file-exists? pktsdir)) + (debug:print 0 *default-log-port* "ERROR: packets directory " pktsdir " does not exist.")) + ((not (directory? pktsdir)) + (debug:print 0 *default-log-port* "ERROR: packets directory path " pktsdir " is not a directory.")) + ((not (file-read-access? pktsdir)) + (debug:print 0 *default-log-port* "ERROR: packets directory path " pktsdir " is not readable.")) + (else + (debug:print-info 0 *default-log-port* "Loading packets found in " pktsdir) + (let ((pkts (glob (conc pktsdir "/*.pkt")))) + (for-each + (lambda (pkt) + (let* ((uuid (cadr (string-match ".*/([0-9a-f]+).pkt" pkt))) + (exists (lookup-by-uuid pdb uuid #f))) + (if (not exists) + (let* ((pktdat (string-intersperse + (with-input-from-file pkt read-lines) + "\n")) + (apkt (pkt->alist pktdat)) + (ptype (alist-ref 'T apkt))) + (add-to-queue pdb pktdat uuid (or ptype 'cmd) #f 0) + (debug:print 4 *default-log-port* "Added " uuid " of type " ptype " to queue")) + (debug:print 4 *default-log-port* "pkt: " uuid " exists, skipping...") + ))) + pkts))))) + pktsdirs)) + use-lt: use-lt)) + +(define (common:get-pkt-alists pkts) + (map (lambda (x) + (alist-ref 'apkt x)) ;; 'pkta pulls out the alist from the read pkt + pkts)) + +;; given list of pkts (alist mode) return list of D cards as Unix epoch, sorted descending +;; also delete duplicates by target i.e. (car pkt) +;; +(define (common:get-pkt-times pkts) + (delete-duplicates + (sort + (map (lambda (x) + `(,(alist-ref 't x) . ,(string->number (alist-ref 'D x)))) + pkts) + (lambda (a b)(> (cdr a)(cdr b)))) ;; sort descending + (lambda (a b)(equal? (car a)(car b))))) ;; remove duplicates by target + + + +;; accept an alist or hash table containing envvar/env value pairs (value of #f causes unset) +;; execute thunk in context of environment modified as per this list +;; restore env to prior state then return value of eval'd thunk. +;; ** this is not thread safe ** +(define (common:with-env-vars delta-env-alist-or-hash-table thunk) + (let* ((delta-env-alist (if (hash-table? delta-env-alist-or-hash-table) + (hash-table->alist delta-env-alist-or-hash-table) + delta-env-alist-or-hash-table)) + (restore-thunks + (filter + identity + (map (lambda (env-pair) + (let* ((env-var (car env-pair)) + (new-val (let ((tmp (cdr env-pair))) + (if (list? tmp) (car tmp) tmp))) + (current-val (get-environment-variable env-var)) + (restore-thunk + (cond + ((not current-val) (lambda () (unsetenv env-var))) + ((not (string? new-val)) #f) + ((eq? current-val new-val) #f) + (else + (lambda () (setenv env-var current-val)))))) + ;;(when (not (string? new-val)) + ;; (debug:print 0 *default-log-port* " PROBLEM: not a string: "new-val"\n from env-alist:\n"delta-env-alist) + ;; (pp delta-env-alist) + ;; (exit 1)) + + + (cond + ((not new-val) ;; modify env here + (unsetenv env-var)) + ((string? new-val) + (setenv env-var new-val))) + restore-thunk)) + delta-env-alist)))) + (let ((rv (thunk))) + (for-each (lambda (x) (x)) restore-thunks) ;; restore env to original state + rv))) + +(define *common:thread-punchlist* (make-hash-table)) +(define (common:send-thunk-to-background-thread thunk #!key (name #f)) + ;;(BB> "launched thread " name) + + ;; we need a unique name for the thread. + (let* ((realname (if name + (if (not (hash-table-ref/default *common:thread-punchlist* name #f)) + name + (conc name"-" (symbol->string (gensym)))) + (conc "anonymous-"(symbol->string (gensym))))) + (realthunk (lambda () + (let ((res (thunk))) + (hash-table-delete! *common:thread-punchlist* realname) + res))) + (thread (make-thread realthunk realname))) + (hash-table-set! *common:thread-punchlist* realname thread) + (thread-start! thread) + )) + +(define (common:join-backgrounded-threads) + ;; may need to trap and ignore exceptions -- dunno how atomic threads are... + (for-each + (lambda (thread-name) + (let* ((thread (hash-table-ref/default *common:thread-punchlist* thread-name #f))) + (if thread + (handle-exceptions + exn + (begin + (debug:print 0 *default-log-port* "joining threads failed. exn=" exn) + #t) ;; just ignore it, it might have died in the meantime so joining it will throw an exception + (thread-join! thread)) + ))) + (hash-table-keys *common:thread-punchlist*))) + +(define *common:telemetry-log-state* 'startup) +(define *common:telemetry-log-socket* #f) + +(define (common:telemetry-log-open) + (if (eq? *common:telemetry-log-state* 'startup) + (let* ((serverhost (configf:lookup *configdat* "telemetry" "host")) + (serverport (configf:lookup-number *configdat* "telemetry" "port")) + (user (or (get-environment-variable "USER") "unknown")) + (host (or (get-environment-variable "HOST") "unknown"))) + (set! *common:telemetry-log-state* + (handle-exceptions + exn + (begin + (debug:print-info 0 *default-log-port* "common-telemetry-log open udp port failure") + 'broken) + (if (and serverhost serverport user host) + (let* ((s (udp-open-socket))) + ;;(udp-bind! s #f 0) + (udp-connect! s serverhost serverport) + (set! *common:telemetry-log-socket* s) + 'open) + 'not-needed)))))) + +(define (common:telemetry-log event #!key (payload '())) + (if (eq? *common:telemetry-log-state* 'startup) + (common:telemetry-log-open)) + + (if (eq? 'open *common:telemetry-log-state*) + (handle-exceptions + exn + (begin + (debug:print-info 0 *default-log-port* "common-telemetry-log comms failure ; disabled (no server?)") + ;;(define *common:telemetry-log-state* 'broken-or-no-server-preclose) + ;;(common:telemetry-log-close) + (define *common:telemetry-log-state* 'broken-or-no-server) + (set! *common:telemetry-log-socket* #f) + ) + (if (and *common:telemetry-log-socket* event) ;; TODO - filter on event against telemetry.want-events + (let* ((user (or (get-environment-variable "USER") "unknown")) + (host (or (get-environment-variable "HOST") "unknown")) + (start (conc "[megatest "event"]")) + (toppath (or *toppath* "/dev/null")) + (payload-serialized + (base64:base64-encode + (z3:encode-buffer + (with-output-to-string (lambda () (pp payload)))))) + (msg (conc user":"host":"start":"(current-process-id)":"(car (argv))":" + toppath":"payload-serialized))) + (udp-send *common:telemetry-log-socket* msg)))))) + +(define (common:telemetry-log-close) + (when (or (member *common:telemetry-log-state* '(broken-or-no-server-preclose open)) *common:telemetry-log-socket*) + (handle-exceptions + exn + (begin + (define *common:telemetry-log-state* 'closed-fail) + (debug:print-info 0 *default-log-port* "common-telemetry-log closure failure") + ) + (begin + (define *common:telemetry-log-state* 'closed) + (udp-close-socket *common:telemetry-log-socket*) + (set! *common:telemetry-log-socket* #f))))) Index: common_records.scm ================================================================== --- common_records.scm +++ common_records.scm @@ -1,14 +1,23 @@ ;;====================================================================== ;; Copyright 2006-2012, Matthew Welland. ;; -;; This program is made available under the GNU GPL version 2.0 or -;; greater. See the accompanying file COPYING for details. +;; This file is part of Megatest. +;; +;; Megatest is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. +;; +;; Megatest is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. ;; -;; This program is distributed WITHOUT ANY WARRANTY; without even the -;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR -;; PURPOSE. +;; You should have received a copy of the GNU General Public License +;; along with Megatest. If not, see . +;; ;;====================================================================== ;; (use trace) (include "altdb.scm") @@ -26,13 +35,28 @@ (define-syntax define-simple-syntax (syntax-rules () ((_ (name arg ...) body ...) (define-syntax name (syntax-rules () ((name arg ...) (begin body ...))))))) +;; (define-syntax common:handle-exceptions +;; (syntax-rules () +;; ((_ exn-in errstmt ...)(handle-exceptions exn-in errstmt ...)))) + +;; this works, why didn't I use it more? +(define-syntax common:debug-handle-exceptions + (syntax-rules () + ((_ debug exn errstmt body ...) + (if debug + (begin body ...) + (handle-exceptions exn errstmt body ...))))) + (define-syntax common:handle-exceptions (syntax-rules () - ((_ exn-in errstmt ...)(handle-exceptions exn-in errstmt ...)))) + ((_ exn errstmt body ...) + (begin body ...)))) + +;; (define handle-exceptions common:handle-exceptions) ;; iup callbacks are not dumping the stack, this is a work-around ;; (define-simple-syntax (debug:catch-and-dump proc procname) (handle-exceptions @@ -44,23 +68,39 @@ (print ((condition-property-accessor 'exn 'message) exn)) (print "Callback error in " procname) (print "Full condition info:\n" (condition->list exn))))) (proc))) +;; Need a mutex protected way to get and set values +;; or use (define-simple-syntax ?? +;; +(define-inline (with-mutex mtx accessor record . val) + (mutex-lock! mtx) + (let ((res (apply accessor record val))) + (mutex-unlock! mtx) + res)) + +;; this was cached based on results from profiling but it turned out the profiling +;; somehow went wrong - perhaps too many processes writing to it. Leaving the caching +;; in for now but can probably take it out later. +;; (define (debug:calc-verbosity vstr) - (cond - ((number? vstr) vstr) - ((not (string? vstr)) 1) - ;; ((string-match "^\\s*$" vstr) 1) - (vstr (let ((debugvals (filter number? (map string->number (string-split vstr ","))))) - (cond - ((> (length debugvals) 1) debugvals) - ((> (length debugvals) 0)(car debugvals)) - (else 1)))) - ((args:get-arg "-v") 2) - ((args:get-arg "-q") 0) - (else 1))) + (or (hash-table-ref/default *verbosity-cache* vstr #f) + (let ((res (cond + ((number? vstr) vstr) + ((not (string? vstr)) 1) + ;; ((string-match "^\\s*$" vstr) 1) + (vstr (let ((debugvals (filter number? (map string->number (string-split vstr ","))))) + (cond + ((> (length debugvals) 1) debugvals) + ((> (length debugvals) 0)(car debugvals)) + (else 1)))) + ((args:get-arg "-v") 2) + ((args:get-arg "-q") 0) + (else 1)))) + (hash-table-set! *verbosity-cache* vstr res) + res))) ;; check verbosity, #t is ok (define (debug:check-verbosity verbosity vstr) (if (not (or (number? verbosity) (list? verbosity))) @@ -81,20 +121,22 @@ (list? n)) (not (null? (lset-intersection! eq? *verbosity* n)))) ((and (number? *verbosity*) (list? n)) (member *verbosity* n)))) - + (define (debug:setup) (let ((debugstr (or (args:get-arg "-debug") + (args:get-arg "-debug-noprop") (getenv "MT_DEBUG_MODE")))) (set! *verbosity* (debug:calc-verbosity debugstr)) (debug:check-verbosity *verbosity* debugstr) ;; if we were handed a bad verbosity rule then we will override it with 1 and continue (if (not *verbosity*)(set! *verbosity* 1)) - (if (or (args:get-arg "-debug") - (not (getenv "MT_DEBUG_MODE"))) + (if (and (not (args:get-arg "-debug-noprop")) + (or (args:get-arg "-debug") + (not (getenv "MT_DEBUG_MODE")))) (setenv "MT_DEBUG_MODE" (if (list? *verbosity*) (string-intersperse (map conc *verbosity*) ",") (conc *verbosity*)))))) (define (debug:print n e . params) @@ -104,14 +146,83 @@ (if *logging* (db:log-event (apply conc params)) (apply print params) ))))) +;; Brandon's debug printer shortcut (indulge me :) +(define *BB-process-starttime* (current-milliseconds)) +(define (BB> . in-args) + (let* ((stack (get-call-chain)) + (location "??")) + (for-each + (lambda (frame) + (let* ((this-loc (vector-ref frame 0)) + (temp (string-split (->string this-loc) " ")) + (this-func (if (and (list? temp) (> (length temp) 1)) (cadr temp) "???"))) + (if (equal? this-func "BB>") + (set! location this-loc)))) + stack) + (let* ((color-on "\x1b[1m") + (color-off "\x1b[0m") + (dp-args + (append + (list 0 *default-log-port* + (conc color-on location "@"(/ (- (current-milliseconds) *BB-process-starttime*) 1000) color-off " ") ) + in-args))) + (apply debug:print dp-args)))) + +(define *BBpp_custom_expanders_list* (make-hash-table)) + + + +;; register hash tables with BBpp. +(hash-table-set! *BBpp_custom_expanders_list* HASH_TABLE: + (cons hash-table? hash-table->alist)) + +;; test name converter +(define (BBpp_custom_converter arg) + (let ((res #f)) + (for-each + (lambda (custom-type-name) + (let* ((custom-type-info (hash-table-ref *BBpp_custom_expanders_list* custom-type-name)) + (custom-type-test (car custom-type-info)) + (custom-type-converter (cdr custom-type-info))) + (when (and (not res) (custom-type-test arg)) + (set! res (custom-type-converter arg))))) + (hash-table-keys *BBpp_custom_expanders_list*)) + (if res (BBpp_ res) arg))) + +(define (BBpp_ arg) + (cond + ;;((SOMESTRUCT? arg) (cons SOMESTRUCT: (SOMESTRUCT->alist arg))) + ;;((dboard:tabdat? arg) (cons dboard:tabdat: (dboard:tabdat->alist arg))) + ((hash-table? arg) + (let ((al (hash-table->alist arg))) + (BBpp_ (cons HASH_TABLE: al)))) + ((null? arg) '()) + ;;((list? arg) (cons (BBpp_ (car arg)) (BBpp_ (cdr arg)))) + ((pair? arg) (cons (BBpp_ (car arg)) (BBpp_ (cdr arg)))) + (else (BBpp_custom_converter arg)))) + +;; Brandon's pretty printer. It expands hashes and custom types in addition to regular pp +(define (BBpp arg) + (pp (BBpp_ arg))) + +;(use define-macro) +(define-syntax inspect + (syntax-rules () + [(_ x) + ;; (with-output-to-port (current-error-port) + (printf "~a is: ~a\n" 'x (with-output-to-string (lambda () (BBpp x)))) + ;; ) + ] + [(_ x y ...) (begin (inspect x) (inspect y ...))])) + (define (debug:print-error n e . params) ;; normal print (if (debug:debug-mode n) - (with-output-to-port (or e (current-error-port)) + (with-output-to-port (if (port? e) e (current-error-port)) (lambda () (if *logging* (db:log-event (apply conc params)) ;; (apply print "pid:" (current-process-id) " " params) (apply print "ERROR: " params) @@ -123,19 +234,21 @@ (apply print "ERROR: " params) )))) (define (debug:print-info n e . params) (if (debug:debug-mode n) - (with-output-to-port (or e (current-error-port)) + (with-output-to-port (if (port? e) e (current-error-port)) (lambda () (if *logging* (let ((res (format#format #f "INFO: (~a) ~a" n (apply conc params)))) (db:log-event res)) ;; (apply print "pid:" (current-process-id) " " "INFO: (" n ") " params) ;; res) (apply print "INFO: (" n ") " params) ;; res) ))))) + + ;; if a value is printable (i.e. string or number) return the value ;; else return an empty string (define-inline (printable val) (if (or (number? val)(string? val)) val "")) ADDED commonmod.scm Index: commonmod.scm ================================================================== --- /dev/null +++ commonmod.scm @@ -0,0 +1,162 @@ +;;====================================================================== +;; Copyright 2017, Matthew Welland. +;; +;; This file is part of Megatest. +;; +;; Megatest is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. +;; +;; Megatest is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with Megatest. If not, see . + +;;====================================================================== + +(declare (unit commonmod)) + +(module commonmod + * + +(import scheme chicken data-structures extras files) +(import (prefix sqlite3 sqlite3:) posix typed-records srfi-18 srfi-69 + md5 message-digest + regex srfi-1) + +;;====================================================================== +;; CONTENTS +;; +;; config file utils +;; misc conversion, data manipulation functions +;; testsuite and area utilites +;; +;;====================================================================== + +(include "megatest-version.scm") +(include "megatest-fossil-hash.scm") + +(define (get-full-version) + (conc megatest-version "-" megatest-fossil-hash)) + +(define (version-signature) + (conc megatest-version "-" (substring megatest-fossil-hash 0 4))) + + +;;====================================================================== +;; config file utils +;;====================================================================== + +(define (lookup cfgdat section var) + (if (hash-table? cfgdat) + (let ((sectdat (hash-table-ref/default cfgdat section '()))) + (if (null? sectdat) + #f + (let ((match (assoc var sectdat))) + (if match ;; (and match (list? match)(> (length match) 1)) + (cadr match) + #f)) + )) + #f)) + +;; returns var key1=val1; key2=val2 ... as alist +(define (get-key-list cfgdat section var) + ;; convert string a=1; b=2; c=a silly thing; d= + (let ((valstr (lookup cfgdat section var))) + (if valstr + (val->alist valstr) + '()))) ;; should it return empty list or #f to indicate not set? + + +(define (get-section cfgdat section) + (hash-table-ref/default cfgdat section '())) + +;;====================================================================== +;; misc conversion, data manipulation functions +;;====================================================================== + +;; if it looks like a number -> convert it to a number, else return it +;; +(define (lazy-convert inval) + (let* ((as-num (if (string? inval)(string->number inval) #f))) + (or as-num inval))) + +;; to '((a . 1)(b . 2)(c . "a silly thing")(d . "")) +;; +(define (val->alist val #!key (convert #f)) + (let ((val-list (string-split-fields ";\\s*" val #:infix))) + (if val-list + (map (lambda (x) + (let ((f (string-split-fields "\\s*=\\s*" x #:infix))) + (case (length f) + ((0) `(,#f)) ;; null string case + ((1) `(,(string->symbol (car f)))) + ((2) `(,(string->symbol (car f)) . + ,(let ((inval (cadr f))) + (if convert (lazy-convert inval) inval)))) + (else f)))) + (filter (lambda (x) + (not (string-match "^\\s*" x))) + val-list)) + '()))) + +;;====================================================================== +;; testsuite and area utilites +;;====================================================================== + +(define (get-testsuite-name toppath configdat) + (or (lookup configdat "setup" "area-name") + (lookup configdat "setup" "testsuite") + (get-environment-variable "MT_TESTSUITE_NAME") + (if (string? toppath) + (pathname-file toppath) + #f))) + +(define (get-area-path-signature toppath #!optional (short #f)) + (let ((res (message-digest-string (md5-primitive) toppath))) + (if short + (substring res 0 4) + res))) + +(define (get-area-name configdat toppath #!optional (short #f)) + ;; look up my area name in areas table (future) + ;; generate auto name + (conc (get-area-path-signature toppath short) + "-" + (get-testsuite-name toppath configdat))) + +;; need generic find-record-with-var-nmatching-val +;; +(define (path->area-record cfgdat path) + (let* ((areadat (get-cfg-areas cfgdat)) + (all (filter (lambda (x) + (let* ((keyvals (cdr x)) + (pth (alist-ref 'path keyvals))) + (equal? path pth))) + areadat))) + (if (null? all) + #f + (car all)))) ;; return first match + +;; given a config return an alist of alists +;; area-name => data +;; +(define (get-cfg-areas cfgdat) + (let ((adat (get-section cfgdat "areas"))) + (map (lambda (entry) + `(,(car entry) . + ,(val->alist (cadr entry)))) + adat))) + +;; (define (debug:print . params) #f) +;; (define (debug:print-info . params) #f) +;; +;; (define (set-functions dbgp dbgpinfo) +;; (set! debug:print dbgp) +;; (set! debug:print-info dbgpinfo)) + +) Index: commonstructs ================================================================== --- commonstructs +++ commonstructs @@ -1,5 +1,21 @@ +# Copyright 2006-2017, Matthew Welland. +# +# This file is part of Megatest. +# +# Megatest is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# Megatest is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with Megatest. If not, see . The database keys, runs are indexed on this keys: (db:get-keys #f) => (#("OS" "TEXT") Index: configf.scm ================================================================== --- configf.scm +++ configf.scm @@ -1,39 +1,49 @@ ;;====================================================================== ;; Copyright 2006-2012, Matthew Welland. ;; -;; This program is made available under the GNU GPL version 2.0 or -;; greater. See the accompanying file COPYING for details. +;; This file is part of Megatest. +;; +;; Megatest is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. +;; +;; Megatest is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. ;; -;; This program is distributed WITHOUT ANY WARRANTY; without even the -;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR -;; PURPOSE. +;; You should have received a copy of the GNU General Public License +;; along with Megatest. If not, see . + ;;====================================================================== ;;====================================================================== ;; Config file handling ;;====================================================================== -(use regex regex-case) ;; directory-utils) +(use regex regex-case matchable) ;; directory-utils) (declare (unit configf)) (declare (uses process)) (declare (uses env)) +(declare (uses keys)) (include "common_records.scm") ;; return list (path fullpath configname) (define (find-config configname #!key (toppath #f)) (if toppath (let ((cfname (conc toppath "/" configname))) - (if (file-exists? cfname) + (if (common:file-exists? cfname) (list toppath cfname configname) (list #f #f #f))) (let* ((cwd (string-split (current-directory) "/"))) (let loop ((dir cwd)) (let* ((path (conc "/" (string-intersperse dir "/"))) (fullpath (conc path "/" configname))) - (if (file-exists? fullpath) + (if (common:file-exists? fullpath) (list path fullpath configname) (let ((remcwd (take dir (- (length dir) 1)))) (if (null? remcwd) (list #f #f #f) ;; #f #f) (loop remcwd))))))))) @@ -41,26 +51,36 @@ (define (config:assoc-safe-add alist key val #!key (metadata #f)) (let ((newalist (filter (lambda (x)(not (equal? key (car x)))) alist))) (append newalist (list (if metadata (list key val metadata) (list key val)))))) + +(define (configf:section-var-set! cfgdat section-name var value #!key (metadata #f)) + (hash-table-set! cfgdat section-name + (config:assoc-safe-add + (hash-table-ref/default cfgdat section-name '()) + var value metadata: metadata))) (define (config:eval-string-in-environment str) - (handle-exceptions - exn - (begin - (debug:print-error 0 *default-log-port* "problem evaluating \"" str "\" in the shell environment") - #f) - (let ((cmdres (process:cmd-run->list (conc "echo " str)))) - (if (null? cmdres) "" - (caar cmdres))))) + ;; (if (or (string-null? str) + ;; (equal? "!" (substring str 0 1))) ;; null string or starts with ! are preserved but NOT set in the environment + str + (handle-exceptions + exn + (begin + (debug:print-error 0 *default-log-port* "problem evaluating \"" str "\" in the shell environment, exn=" exn) + #f) + (let ((cmdres (process:cmd-run->list (conc "echo " str)))) + (if (null? cmdres) "" + (caar cmdres))))) ;; ) ;;====================================================================== ;; Make the regexp's needed globally available ;;====================================================================== (define configf:include-rx (regexp "^\\[include\\s+(.*)\\]\\s*$")) +(define configf:script-rx (regexp "^\\[scriptinc\\s+(\\S+)([^\\]]*)\\]\\s*$")) ;; include output from a script (define configf:section-rx (regexp "^\\[(.*)\\]\\s*$")) (define configf:blank-l-rx (regexp "^\\s*$")) (define configf:key-sys-pr (regexp "^(\\S+)\\s+\\[system\\s+(\\S+.*)\\]\\s*$")) (define configf:key-val-pr (regexp "^(\\S+)(\\s+(.*)|())$")) (define configf:key-no-val (regexp "^(\\S+)(\\s*)$")) @@ -68,11 +88,15 @@ (define configf:cont-ln-rx (regexp "^(\\s+)(\\S+.*)$")) (define configf:settings (regexp "^\\[configf:settings\\s+(\\S+)\\s+(\\S+)]\\s*$")) ;; read a line and process any #{ ... } constructs -(define configf:var-expand-regex (regexp "^(.*)#\\{(scheme|system|shell|getenv|get|runconfigs-get|rget)\\s+([^\\}\\{]*)\\}(.*)")) +(define configf:var-expand-regex (regexp "^(.*)#\\{(scheme|system|shell|getenv|get|runconfigs-get|rget|scm|sh|rp|gv|g|mtrah)\\s+([^\\}\\{]*)\\}(.*)")) + +(define (configf:system ht cmd) + (system cmd) + ) (define (configf:process-line l ht allow-system #!key (linenum #f)) (let loop ((res l)) (if (string? res) (let ((matchdat (string-search configf:var-expand-regex res))) @@ -83,36 +107,43 @@ (poststr (list-ref matchdat 4)) (result #f) (start-time (current-seconds)) (cmdsym (string->symbol cmdtype)) (fullcmd (case cmdsym - ((scheme)(conc "(lambda (ht)" cmd ")")) - ((system)(conc "(lambda (ht)(system \"" cmd "\"))")) - ((shell) (conc "(lambda (ht)(shell \"" cmd "\"))")) - ((getenv)(conc "(lambda (ht)(get-environment-variable \"" cmd "\"))")) - ((get) - (let* ((parts (string-split cmd)) - (sect (car parts)) - (var (cadr parts))) - (conc "(lambda (ht)(config-lookup ht \"" sect "\" \"" var "\"))"))) - ((runconfigs-get) (conc "(lambda (ht)(runconfigs-get ht \"" cmd "\"))")) - ((rget) (conc "(lambda (ht)(runconfigs-get ht \"" cmd "\"))")) + ((scheme scm) (conc "(lambda (ht)" cmd ")")) + ((system) (conc "(lambda (ht)(configf:system ht \"" cmd "\"))")) + ((shell sh) (conc "(lambda (ht)(string-translate (shell \"" cmd "\") \"\n\" \" \"))")) + ((realpath rp)(conc "(lambda (ht)(common:nice-path \"" cmd "\"))")) + ((getenv gv) (conc "(lambda (ht)(get-environment-variable \"" cmd "\"))")) + ((mtrah) (conc "(lambda (ht)" + " (let ((extra \"" cmd "\"))" + " (conc (or *toppath* (get-environment-variable \"MT_RUN_AREA_HOME\"))" + " (if (string-null? extra) \"\" \"/\")" + " extra)))")) + ((get g) + (match (string-split cmd) + ((sect var)(conc "(lambda (ht)(configf:lookup ht \"" sect "\" \"" var "\"))")) + (else + (debug:print-error 0 *default-log-port* "#{get ...} used with only one parameter, \"" cmd "\", two needed.") + "(lambda (ht) #f)"))) + ((runconfigs-get rget) (conc "(lambda (ht)(runconfigs-get ht \"" cmd "\"))")) + ;; ((rget) (conc "(lambda (ht)(runconfigs-get ht \"" cmd "\"))")) (else "(lambda (ht)(print \"ERROR\") \"ERROR\")")))) ;; (print "fullcmd=" fullcmd) (handle-exceptions exn (begin - (debug:print 0 *default-log-port* "WARNING: failed to process config input \"" l "\"") + (debug:print 0 *default-log-port* "WARNING: failed to process config input \"" l "\", exn=" exn) (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) ;; (print "exn=" (condition->list exn)) - (set! result (conc "#{( " cmdtype ") " cmd"}"))) + (set! result (conc "#{( " cmdtype ") " cmd "}, full expansion: " fullcmd))) (if (or allow-system - (not (member cmdtype '("system" "shell")))) + (not (member cmdtype '("system" "shell" "sh")))) (with-input-from-string fullcmd (lambda () (set! result ((eval (read)) ht)))) - (set! result (conc "#{(" cmdtype ") " cmd "}")))) + (set! result (conc "#{(" cmdtype ") " cmd "}")))) (case cmdsym ((system shell scheme) (let ((delta (- (current-seconds) start-time))) (if (> delta 2) (debug:print-info 0 *default-log-port* "for line \"" l "\"\n command: " cmd " took " delta " seconds to run with output:\n " result) @@ -158,170 +189,314 @@ (configf:process-line inl ht allow-processing)) ((return-string) inl) (else (configf:process-line inl ht allow-processing))))) - (if (and (string? res) - (not (equal? (hash-table-ref/default settings "trim-trailing-spaces" "no") "no"))) + (if (and (string? res) ;; must set to "no" to force NOT trimming trailing spaces + (not (equal? (hash-table-ref/default settings "trim-trailing-spaces" "yes") "no"))) (string-substitute "\\s+$" "" res) res)))))) - + +(define (configf:cfgdat->env-alist section cfgdat-ht allow-system) + (filter + (lambda (pair) + (let* ((var (car pair)) + (val (cdr pair))) + (cons var + (cond + ((and allow-system (procedure? val)) ;; if we decided to use something other than #t or #f for allow-system ('return-procs or 'return-string) , this may become problematic + (val)) + ((procedure? val) #f) + ((string? val) val) + (else "#f"))))) + (append + (hash-table-ref/default cfgdat-ht "default" '()) + (if (equal? section "default") '() (hash-table-ref/default cfgdat-ht section '()))))) + (define (calc-allow-system allow-system section sections) (if sections (and (or (equal? "default" section) (member section sections)) allow-system) ;; account for sections and return allow-system as it might be a symbol such as return-strings allow-system)) +;; given a config hash and a section name, apply that section to all matching sections (using wildcard % or regex if /..../) +;; remove the section when done so that there is no downstream clobbering +;; +(define (configf:apply-wildcards ht section-name) + (if (hash-table-exists? ht section-name) + (let* ((vars (hash-table-ref ht section-name)) + (rxstr (if (string-contains section-name "%") + (string-substitute (regexp "%") ".*" section-name) + (string-substitute (regexp "^/(.*)/$") "\\1" section-name))) + (rx (regexp rxstr))) + ;; (print "\nsection-name: " section-name " rxstr: " rxstr) + (for-each + (lambda (section) + (if section + (let ((same-section (string=? section-name section)) + (rx-match (string-match rx section))) + ;; (print "section: " section " vars: " vars " same-section: " same-section " rx-match: " rx-match) + (if (and (not same-section) rx-match) + (for-each + (lambda (bundle) + ;; (print "bundle: " bundle) + (let ((key (car bundle)) + (val (cadr bundle)) + (meta (if (> (length bundle) 2)(caddr bundle) #f))) + (hash-table-set! ht section (config:assoc-safe-add (hash-table-ref ht section) key val metadata: meta)))) + vars))))) + (hash-table-keys ht)))) + ht) + ;; read a config file, returns hash table of alists ;; read a config file, returns hash table of alists ;; adds to ht if given (must be #f otherwise) +;; allow-system: +;; #f - do not evaluate [system +;; #t - immediately evaluate [system and store result as string +;; 'return-procs -- return a proc taking ht as an argument that may be evaulated at some future time +;; 'return-string -- return a string representing a proc taking ht as an argument that may be evaulated at some future time ;; envion-patt is a regex spec that identifies sections that will be eval'd ;; in the environment on the fly ;; sections: #f => get all, else list of sections to gather ;; post-section-procs alist of section-pattern => proc, where: (proc section-name next-section-name ht curr-path) +;; apply-wildcards: #t/#f - apply vars from targets with % wildcards to all matching sections ;; -(define (read-config path ht allow-system #!key (environ-patt #f)(curr-section #f)(sections #f)(settings (make-hash-table))(keep-filenames #f)(post-section-procs '())) - (debug:print-info 5 *default-log-port* "read-config " path " allow-system " allow-system " environ-patt " environ-patt " curr-section: " curr-section " sections: " sections " pwd: " (current-directory)) +(define (read-config path ht allow-system #!key (environ-patt #f) (curr-section #f) + (sections #f) (settings (make-hash-table)) (keep-filenames #f) + (post-section-procs '()) (apply-wildcards #t) ) (debug:print 9 *default-log-port* "START: " path) - (if (not (file-exists? path)) +;; (if *configdat* +;; (common:save-pkt `((action . read-config) +;; (f . ,(cond ((string? path) path) +;; ((port? path) "port") +;; (else (conc path)))) +;; (T . configf)) +;; *configdat* #t add-only: #t)) + (if (and (not (port? path)) + (not (common:file-exists? path))) ;; for case where we are handed a port (begin (debug:print-info 1 *default-log-port* "read-config - file not found " path " current path: " (current-directory)) ;; WARNING: This is a risky change but really, we should not return an empty hash table if no file read? #f) ;; (if (not ht)(make-hash-table) ht)) - (let ((inp (open-input-file path)) + (let ((inp (if (string? path) + (open-input-file path) + path)) ;; we can be handed a port (res (if (not ht)(make-hash-table) ht)) (metapath (if (or (debug:debug-mode 9) keep-filenames) - path #f))) + path #f)) + (process-wildcards (lambda (res curr-section-name) + (if (and apply-wildcards + (or (string-contains curr-section-name "%") ;; wildcard + (string-match "/.*/" curr-section-name))) ;; regex + (begin + (configf:apply-wildcards res curr-section-name) + (hash-table-delete! res curr-section-name)))))) ;; NOTE: if the section is a wild card it will be REMOVED from res (let loop ((inl (configf:read-line inp res (calc-allow-system allow-system curr-section sections) settings)) ;; (read-line inp)) (curr-section-name (if curr-section curr-section "default")) (var-flag #f);; turn on for key-var-pr and cont-ln-rx, turn off elsewhere (lead #f)) (debug:print-info 8 *default-log-port* "curr-section-name: " curr-section-name " var-flag: " var-flag "\n inl: \"" inl "\"") (if (eof-object? inl) (begin - (close-input-port inp) - (hash-table-delete! res "") ;; we are using "" as a dumping ground and must remove it before returning the ht + ;; process last section for wildcards + (process-wildcards res curr-section-name) + (if (string? path) ;; we received a path, not a port, thus we are responsible for closing it. + (close-input-port inp)) + (if (list? sections) ;; delete all sections except given when sections is provided + (for-each + (lambda (section) + (if (not (member section sections)) + (hash-table-delete! res section))) ;; we are using "" as a dumping ground and must remove it before returning the ht + (hash-table-keys res))) (debug:print 9 *default-log-port* "END: " path) - res) + res + ) ;; retval (regex-case inl - (configf:comment-rx _ (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f)) - (configf:blank-l-rx _ (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f)) - (configf:settings ( x setting val ) (begin - (hash-table-set! settings setting val) - (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f))) - (configf:include-rx ( x include-file ) (let* ((curr-conf-dir (pathname-directory path)) - (full-conf (if (absolute-pathname? include-file) - include-file - (common:nice-path - (conc (if curr-conf-dir - curr-conf-dir - ".") - "/" include-file))))) - (if (file-exists? full-conf) - (begin - ;; (push-directory conf-dir) - (debug:print 9 *default-log-port* "Including: " full-conf) - (read-config full-conf res allow-system environ-patt: environ-patt curr-section: curr-section-name sections: sections settings: settings keep-filenames: keep-filenames) - ;; (pop-directory) - (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f)) - (begin - (debug:print '(2 9) #f "INFO: include file " include-file " not found (called from " path ")") - (debug:print 2 *default-log-port* " " full-conf) - (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f))))) - (configf:section-rx ( x section-name ) (begin - ;; call post-section-procs - (for-each - (lambda (dat) - (let ((patt (car dat)) - (proc (cdr dat))) - (if (string-match patt curr-section-name) - (proc curr-section-name section-name res path)))) - post-section-procs) - (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) - ;; if we have the sections list then force all settings into "" and delete it later? - (if (or (not sections) - (member section-name sections)) - section-name "") ;; stick everything into "" - #f #f))) - (configf:key-sys-pr ( x key cmd ) (if (calc-allow-system allow-system curr-section-name sections) - (let ((alist (hash-table-ref/default res curr-section-name '())) - (val-proc (lambda () - (let* ((start-time (current-seconds)) - (cmdres (process:cmd-run->list cmd)) - (delta (- (current-seconds) start-time)) - (status (cadr cmdres)) - (res (car cmdres))) - (debug:print-info 4 *default-log-port* "" inl "\n => " (string-intersperse res "\n")) - (if (not (eq? status 0)) - (begin - (debug:print-error 0 *default-log-port* "problem with " inl ", return code " status - " output: " cmdres))) - (if (> delta 2) - (debug:print-info 0 *default-log-port* "for line \"" inl "\"\n command: " cmd " took " delta " seconds to run with output:\n " res) - (debug:print-info 9 *default-log-port* "for line \"" inl "\"\n command: " cmd " took " delta " seconds to run with output:\n " res)) - (if (null? res) - "" - (string-intersperse res " ")))))) - (hash-table-set! res curr-section-name - (config:assoc-safe-add alist - key - (case (calc-allow-system allow-system curr-section-name sections) - ((return-procs) val-proc) - ((return-string) cmd) - (else (val-proc))) - metadata: metapath)) - (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f)) - (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f))) - (configf:key-no-val ( x key val) (let* ((alist (hash-table-ref/default res curr-section-name '())) - (fval (or (if (string? val) val #f) ""))) ;; fval should be either "" or " " (one or more spaces) - (debug:print 10 *default-log-port* " setting: [" curr-section-name "] " key " = #t") - (safe-setenv key fval) - (hash-table-set! res curr-section-name - (config:assoc-safe-add alist key fval metadata: metapath)) - (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name key #f))) - (configf:key-val-pr ( x key unk1 val unk2 ) (let* ((alist (hash-table-ref/default res curr-section-name '())) - (envar (and environ-patt (string-search (regexp environ-patt) curr-section-name))) - (realval (if envar - (config:eval-string-in-environment val) - val))) - (debug:print-info 6 *default-log-port* "read-config env setting, envar: " envar " realval: " realval " val: " val " key: " key " curr-section-name: " curr-section-name) - (if envar (safe-setenv key realval)) - (debug:print 10 *default-log-port* " setting: [" curr-section-name "] " key " = " val) - (hash-table-set! res curr-section-name - (config:assoc-safe-add alist key realval metadata: metapath)) - (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name key #f))) + (configf:comment-rx _ (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) + curr-section-name #f #f)) + + (configf:blank-l-rx _ (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) + curr-section-name #f #f)) + (configf:settings ( x setting val ) + (begin + (hash-table-set! settings setting val) + (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) + curr-section-name #f #f))) + + (configf:include-rx ( x include-file ) + (let* ((curr-conf-dir (pathname-directory path)) + (full-conf (if (and (absolute-pathname? include-file) (file-exists? include-file)) + include-file + (common:nice-path + (conc (if curr-conf-dir + curr-conf-dir + ".") + "/" include-file))))) + (let ((all-matches (sort (handle-exceptions exn + (begin + (debug:print '(2 9) *default-log-port* "glob of " full-conf " gave no match. , exn=" exn) + (list)) + (glob full-conf)) string<=?))) + (if (null? all-matches) + (begin + (debug:print '(2 9) #f "INFO: include file(s) matching " include-file " not found (called from " path ")") + (debug:print 2 *default-log-port* " " full-conf)) + (for-each + (lambda (fpath) + ;; (push-directory conf-dir) + (debug:print 9 *default-log-port* "Including: " full-conf) + (read-config fpath res allow-system environ-patt: environ-patt + curr-section: curr-section-name sections: sections settings: settings + keep-filenames: keep-filenames)) + all-matches)) + (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) + curr-section-name #f #f)))) + (configf:script-rx ( x include-script params);; handle-exceptions + ;; exn + ;; (begin + ;; (debug:print '(0 2 9) #f "INFO: include from script " include-script " failed.") + ;; (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f)) + (if (and (common:file-exists? include-script)(file-execute-access? include-script)) + (let* ((local-allow-system (calc-allow-system allow-system curr-section-name sections)) + (env-delta (configf:cfgdat->env-alist curr-section-name res local-allow-system)) + (new-inp-port + (common:with-env-vars + env-delta + (lambda () + (open-input-pipe (conc include-script " " params)))))) + (debug:print '(2 9) *default-log-port* "Including from script output: " include-script) + ;; (print "We got here, calling read-config next. Port is: " new-inp-port) + (read-config new-inp-port res allow-system environ-patt: environ-patt curr-section: curr-section-name sections: sections settings: settings keep-filenames: keep-filenames) + (close-input-port new-inp-port) + (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f)) + (begin + (debug:print 0 *default-log-port* "Script not found or not exectutable: " include-script) + (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f))) + ) ;; ) + (configf:section-rx ( x section-name ) + (begin + ;; call post-section-procs + (for-each + (lambda (dat) + (let ((patt (car dat)) + (proc (cdr dat))) + (if (string-match patt curr-section-name) + (proc curr-section-name section-name res path)))) + post-section-procs) + ;; after gathering the vars for a section and if apply-wildcards is true and if there is a wildcard in the section name process wildcards + ;; NOTE: we are processing the curr-section-name, NOT section-name. + (process-wildcards res curr-section-name) + (if (not (hash-table-ref/default res section-name #f))(hash-table-set! res section-name '())) ;; ensure that mere mention of a section is not lost + (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) + ;; if we have the sections list then force all settings into "" and delete it later? + ;; (if (or (not sections) + ;; (member section-name sections)) + ;; section-name "") ;; stick everything into "". NOPE: We need new strategy. Put stuff in correct sections and then delete all sections later. + section-name + #f #f))) + (configf:key-sys-pr ( x key cmd ) + (if (calc-allow-system allow-system curr-section-name sections) + (let ((alist (hash-table-ref/default res curr-section-name '())) + (val-proc (lambda () + (let* ((start-time (current-seconds)) + (local-allow-system (calc-allow-system allow-system curr-section-name sections)) + (env-delta (configf:cfgdat->env-alist curr-section-name res local-allow-system)) + (cmdres (process:cmd-run->list cmd delta-env-alist-or-hash-table: env-delta)) ;; BB: here is where [system is exec'd. needs to have env from other vars! + (delta (- (current-seconds) start-time)) + (status (cadr cmdres)) + (res (car cmdres))) + (debug:print-info 4 *default-log-port* "" inl "\n => " (string-intersperse res "\n")) + (if (not (eq? status 0)) + (begin + (debug:print-error 0 *default-log-port* "problem with " inl ", return code " status + " output: " cmdres))) + (if (> delta 2) + (debug:print-info 0 *default-log-port* "for line \"" inl "\"\n command: " cmd " took " delta " seconds to run with output:\n " res) + (debug:print-info 9 *default-log-port* "for line \"" inl "\"\n command: " cmd " took " delta " seconds to run with output:\n " res)) + (if (null? res) + "" + (string-intersperse res " ")))))) + (hash-table-set! res curr-section-name + (config:assoc-safe-add alist + key + (case (calc-allow-system allow-system curr-section-name sections) + ((return-procs) val-proc) + ((return-string) cmd) + (else (val-proc))) + metadata: metapath)) + (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f)) + (loop (configf:read-line inp res + (calc-allow-system allow-system curr-section-name sections) + settings) + curr-section-name #f #f))) + + (configf:key-no-val ( x key val) + (let* ((alist (hash-table-ref/default res curr-section-name '())) + (fval (or (if (string? val) val #f) ""))) ;; fval should be either "" or " " (one or more spaces) + (debug:print 10 *default-log-port* " setting: [" curr-section-name "] " key " = #t") + (safe-setenv key fval) + (hash-table-set! res curr-section-name + (config:assoc-safe-add alist key fval metadata: metapath)) + (loop (configf:read-line inp res + (calc-allow-system allow-system curr-section-name sections) + settings) + curr-section-name key #f))) + + (configf:key-val-pr ( x key unk1 val unk2 ) + (let* ((alist (hash-table-ref/default res curr-section-name '())) + (envar (and environ-patt + (string-search (regexp environ-patt) curr-section-name) ;; does the section match the envionpatt? + (and (not (string-null? key)) + (not (equal? "!" (substring key 0 1)))) ;; ! as leading character is a signature to NOT export to the environment + ;; (string-match "^.*:.*:.*$" key) ;; ;; something:something:something reserved for triggers in runconfigs + )) + (realval (if envar + (config:eval-string-in-environment val) + val))) + (debug:print-info 6 *default-log-port* "read-config env setting, envar: " envar " realval: " realval " val: " val " key: " key " curr-section-name: " curr-section-name) + (if envar (safe-setenv key realval)) + (debug:print 10 *default-log-port* " setting: [" curr-section-name "] " key " = " val) + (hash-table-set! res curr-section-name + (config:assoc-safe-add alist key realval metadata: metapath)) + (loop (configf:read-line inp res + (calc-allow-system allow-system curr-section-name sections) settings) + curr-section-name key #f))) ;; if a continued line - (configf:cont-ln-rx ( x whsp val ) (let ((alist (hash-table-ref/default res curr-section-name '()))) - (if var-flag ;; if set to a string then we have a continued var - (let ((newval (conc - (config-lookup res curr-section-name var-flag) "\n" - ;; trim lead from the incoming whsp to support some indenting. - (if lead - (string-substitute (regexp lead) "" whsp) - "") - val))) - ;; (print "val: " val "\nnewval: \"" newval "\"\nvarflag: " var-flag) - (hash-table-set! res curr-section-name - (config:assoc-safe-add alist var-flag newval metadata: metapath)) - (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name var-flag (if lead lead whsp))) - (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f)))) + (configf:cont-ln-rx ( x whsp val ) + (let ((alist (hash-table-ref/default res curr-section-name '()))) + (if var-flag ;; if set to a string then we have a continued var + (let ((newval (conc + (configf:lookup res curr-section-name var-flag) "\n" + ;; trim lead from the incoming whsp to support some indenting. + (if lead + (string-substitute (regexp lead) "" whsp) + "") + val))) + ;; (print "val: " val "\nnewval: \"" newval "\"\nvarflag: " var-flag) + (hash-table-set! res curr-section-name + (config:assoc-safe-add alist var-flag newval metadata: metapath)) + (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name var-flag (if lead lead whsp))) + (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f)))) (else (debug:print-error 0 *default-log-port* "problem parsing " path ",\n \"" inl "\"") (set! var-flag #f) - (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f)))))))) + (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f)))) + ) ;; end loop + ))) ;; pathenvvar will set the named var to the path of the config (define (find-and-read-config fname #!key (environ-patt #f)(given-toppath #f)(pathenvvar #f)) (let* ((curr-dir (current-directory)) (configinfo (find-config fname toppath: given-toppath)) (toppath (car configinfo)) (configfile (cadr configinfo)) (set-fields (lambda (curr-section next-section ht path) - (let ((field-names (if ht (keys:config-get-fields ht) '())) + (let ((field-names (if ht (common:get-fields ht) '())) (target (or (getenv "MT_TARGET")(args:get-arg "-reqtarg")(args:get-arg "-target")))) (debug:print-info 9 *default-log-port* "set-fields with field-names=" field-names " target=" target " curr-section=" curr-section " next-section=" next-section " path=" path " ht=" ht) (if (not (null? field-names))(keys:target-set-args field-names target #f)))))) (if toppath (change-directory toppath)) (if (and toppath pathenvvar)(setenv pathenvvar toppath)) @@ -328,11 +503,11 @@ (let ((configdat (if configfile (read-config configfile #f #t environ-patt: environ-patt post-section-procs: (list (cons "^fields$" set-fields)) #f)))) (if toppath (change-directory curr-dir)) (list configdat toppath configfile fname)))) -(define (config-lookup cfgdat section var) +(define (configf:lookup cfgdat section var) (if (hash-table? cfgdat) (let ((sectdat (hash-table-ref/default cfgdat section '()))) (if (null? sectdat) #f (let ((match (assoc var sectdat))) @@ -340,21 +515,51 @@ (cadr match) #f)) )) #f)) -(define configf:lookup config-lookup) +;; use to have definitive setting: +;; [foo] +;; var yes +;; +;; (configf:var-is? cfgdat "foo" "var" "yes") => #t +;; +(define (configf:var-is? cfgdat section var expected-val) + (equal? (configf:lookup cfgdat section var) expected-val)) + +(define config-lookup configf:lookup) (define configf:read-file read-config) + +;; safely look up a value that is expected to be a number, return +;; a default (#f unless provided) +;; +(define (configf:lookup-number cfgdat section varname #!key (default #f)) + (let* ((val (configf:lookup cfgdat section varname)) + (res (if val + (string->number (string-substitute "\\s+" "" val #t)) + #f))) + (cond + (res res) + (val (debug:print 0 *default-log-port* "ERROR: no number found for [" section "], " varname ", got: " val)) + (else default)))) (define (configf:section-vars cfgdat section) (let ((sectdat (hash-table-ref/default cfgdat section '()))) (if (null? sectdat) '() (map car sectdat)))) (define (configf:get-section cfgdat section) (hash-table-ref/default cfgdat section '())) + +(define (configf:set-section-var cfgdat section var val) + (let ((sectdat (configf:get-section cfgdat section))) + (hash-table-set! cfgdat section + (config:assoc-safe-add sectdat var val)))) + + ;;(append (filter (lambda (x)(not (assoc var sectdat))) sectdat) + ;; (list var val)))) (define (setup) (let* ((configf (find-config "megatest.config")) (config (if configf (read-config configf #f #t) #f))) (if config @@ -404,11 +609,11 @@ (if (null? tal) newres (loop (car tal)(cdr tal) newres)))))) (define (configf:file->list fname) - (if (file-exists? fname) + (if (common:file-exists? fname) (let ((inp (open-input-file fname))) (let loop ((inl (read-line inp)) (res '())) (if (eof-object? inl) (begin @@ -434,11 +639,11 @@ (sechash (make-hash-table)) ;; current section hash, init with hash for "default" section (new #f) ;; put the line to be used in new, if it is to be deleted the set new to #f (secname #f)) ;; step 2: Flatten multiline entries - (if (not (null? fdat))(set! fdat (configf:compress-multi-line fdat))) + (if (not (null? fdat))(set! fdat (configf:compress-multi-lines fdat))) ;; step 3: Modify values per contents of "indat" and remove absent values (if (not (null? fdat)) (let loop ((hed (car fdat)) (tal (cadr fdat)) @@ -449,19 +654,19 @@ (configf:comment-rx _ (set! res (append res (list hed)))) ;; (loop (read-line inp) curr-section-name #f #f)) (configf:blank-l-rx _ (set! res (append res (list hed)))) ;; (loop (read-line inp) curr-section-name #f #f)) (configf:section-rx ( x section-name ) (let ((section-hash (hash-table-ref/default refdat section-name #f))) (if (not section-hash) (let ((newhash (make-hash-table))) - (hash-table-set! refhash section-name newhash) + (hash-table-set! refdat section-name newhash) ;; was refhash - not sure that refdat is correct here (set! sechash newhash)) (set! sechash section-hash)) (set! new hed) ;; will append this at the bottom of the loop (set! secname section-name) )) ;; No need to process key cmd, let it fall though to key val (configf:key-val-pr ( x key val ) - (let ((newval (config-lookup indat sec key))) + (let ((newval (configf:lookup indat secname key))) ;; was sec, bug or correct? ;; can handle newval == #f here => that means key is removed (cond ((equal? newval val) (set! res (append res (list hed)))) ((not newval) ;; key has been removed @@ -483,18 +688,18 @@ (lambda (section) (let ((sdat '()) ;; append needed bits here (svars (configf:section-vars indat section))) (for-each (lambda (var) - (let ((val (config-lookup refdat section var))) + (let ((val (configf:lookup refdat section var))) (if (not val) ;; this one is new (begin (if (null? sdat)(set! sdat (list (conc "[" section "]")))) (set! sdat (append sdat (list (conc var " " val)))))))) svars) (set! fdat (append fdat sdat)))) - (delete-duplicates (append require-sections (hash-table-keys indat)))) + (delete-duplicates (append required-sections (hash-table-keys indat)))) ;; step 5: Write out new file (with-output-to-file fname (lambda () (for-each @@ -508,11 +713,11 @@ ;; reads a refdb into an assoc array of assoc arrays ;; returns (list dat msg) (define (configf:read-refdb refdb-path) (let ((sheets-file (conc refdb-path "/sheet-names.cfg"))) - (if (not (file-exists? sheets-file)) + (if (not (common:file-exists? sheets-file)) (list #f (conc "ERROR: no refdb found at " refdb-path)) (if (not (file-read-access? sheets-file)) (list #f (conc "ERROR: refdb file not readable at " refdb-path)) (let* ((sheets (with-input-from-file sheets-file (lambda () @@ -571,20 +776,46 @@ (lambda (section) (hash-table-set! ht (car section)(cdr section))) adat) ht)) +;; if (define (configf:read-alist fname) - (configf:alist->config - (with-input-from-file fname read))) + (handle-exceptions + exn + (begin + (debug:print-info 0 *default-log-port* "unable to read alist " fname ". exn=" exn) + #f) + (configf:alist->config + (with-input-from-file fname read)))) (define (configf:write-alist cdat fname) - (with-output-to-file fname - (lambda () - (pp (configf:config->alist cdat))))) - - + (if (not (common:faux-lock fname)) + (debug:print 0 *default-log-port* "INFO: Could not get lock on " fname)) + (let* ((dat (configf:config->alist cdat)) + (res + (begin + (with-output-to-file fname ;; first write out the file + (lambda () + (pp dat))) + + (if (common:file-exists? fname) ;; now verify it is readable + (if (configf:read-alist fname) + #t ;; data is good. + (begin + (handle-exceptions + exn + (begin + (debug:print 0 *default-log-port* "deleting " fname " failed, exn=" exn) + #f) + (debug:print 0 *default-log-port* "WARNING: content " dat " for cache " fname " is not readable. Deleting generated file.") + (delete-file fname)) + #f)) + #f)))) + (common:faux-unlock fname) + res)) + ;; convert hierarchial list to ini format ;; (define (configf:config->ini data) (map (lambda (section) ADDED configure Index: configure ================================================================== --- /dev/null +++ configure @@ -0,0 +1,101 @@ +#!/bin/bash + +# Copyright 2006-2017, Matthew Welland. +# +# This file is part of Megatest. +# +# Megatest is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# Megatest is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with Megatest. If not, see . + +# Configure the build + +if [[ "$1"x == "x" ]];then + PREFIX=$PWD +else + PREFIX=$1 +fi + + +#====================================================================== +# Configure stuff needed for eggs +#====================================================================== + +function configure_dependencies () { + + #====================================================================== + # libnanomsg + #====================================================================== + + if [[ ! $(ls /usr/lib/*/libnanomsg*) ]];then + echo "libnanomsg build needed." + echo "BUILD_NANOMSG=yes" >> makefile.inc + fi + + #====================================================================== + # postgresql libraries + #====================================================================== + + if [[ ! $(ls /usr/lib/*/libpq.*) ]];then + echo "Postgresql build needed." + echo "BUILD_POSTGRES=yes" >> makefile.inc + fi + + if [[ ! $(ls /usr/lib/*/libsqlite3.*) ]];then + echo "Sqlite3 build needed." + echo "BUILD_SQLITE3=yes" >> makefile.inc + fi + +} + +#====================================================================== +# Initialize makefile.inc +#====================================================================== + +echo "" > makefile.inc + +#====================================================================== +# Do we need Chicken? +#====================================================================== + +if [[ -e /usr/bin/sw_vers ]]; then + ARCHSTR=$(/usr/bin/sw_vers -productVersion) +else + ARCHSTR=$(lsb_release -sr) +fi + +echo "CKPATH=$PREFIX/.$ARCHSTR" >> makefile.inc +CHICKEN_PREFIX=$PREFIX/bin/.$ARCHSTR + +if [[ ! $(type csi) ]];then + echo "Chicken build needed." + echo "BUILD_CHICKEN=yes" >> makefile.inc + configure_dependencies + echo "include chicken.makefile" >> makefile.inc +else + echo "CSIPATH=$(which csi)" >> makefile.inc + CSIPATH=$(which csi) + echo "CKPATH=$(dirname $(dirname $CSIPATH))" >> makefile.inc +fi + +# Make setup scripts +echo "#!/bin/bash" > setup.sh +echo "export PATH=$CHICKEN_PREFIX/bin:\$PATH" >> setup.sh +echo "export LD_LIBRARY_PATH=$CHICKEN_PREFIX/lib" >> setup.sh +echo 'exec "$@"' >> setup.sh +chmod a+x setup.sh + +echo "setenv PATH $CHICKEN_PREFIX/bin:\$PATH" > setup.csh +echo "setenv LD_LIBRARY_PATH $CHICKEN_PREFIX/lib" >> setup.csh + +echo "All done creating makefile.inc, feel free to edit it!" +echo "run \"setup.sh bash\" or source setup.csh to get PATH and LD_LIBRARY_PATH adjusted" ADDED cookie.scm Index: cookie.scm ================================================================== --- /dev/null +++ cookie.scm @@ -0,0 +1,23 @@ +;;====================================================================== +;; Copyright 2019, Matthew Welland. +;; +;; This file is part of Megatest. +;; +;; Megatest is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. +;; +;; Megatest is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with Megatest. If not, see . + +;;====================================================================== + +(declare (unit cookie)) + +(include "stml2/cookie.scm") DELETED daemon.scm Index: daemon.scm ================================================================== --- daemon.scm +++ /dev/null @@ -1,45 +0,0 @@ -;; Taken from the chicken 3.x daemon egg -;; -;; Copyright (c) 2007 Hans Bulfone -;; All rights reserved. -;; -;; Redistribution and use in source and binary forms, with or without -;; modification, are permitted provided that the following conditions are met: -;; -;; * Redistributions of source code must retain the above copyright notice, -;; this list of conditions and the following disclaimer. -;; * Redistributions in binary form must reproduce the above copyright -;; notice, this list of conditions and the following disclaimer in the -;; documentation and/or other materials provided with the distribution. -;; * Neither the name of the author nor the names of his contributors may -;; be used to endorse or promote products derived from this software -;; without specific prior written permission. -;; -;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" -;; AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, -;; THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -;; PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR -;; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, -;; EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, -;; PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; -;; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, -;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR -;; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF -;; ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -(declare (unit daemon)) - -(define (daemon:ize) - (change-directory "/") - (let ((fd-r (file-open "/dev/null" open/rdonly)) - (fd-w (file-open "/dev/null" open/wronly))) - (duplicate-fileno fd-r 0) - (duplicate-fileno fd-w 1) - (file-close fd-r) - (file-close fd-w)) - (let ((child-pid (process-fork))) - (if (not (zero? child-pid)) - (exit 0))) - (create-session) - (duplicate-fileno 1 2) - (void)) ADDED dashboard-context-menu.scm Index: dashboard-context-menu.scm ================================================================== --- /dev/null +++ dashboard-context-menu.scm @@ -0,0 +1,350 @@ +;;====================================================================== +;; Copyright 2006-2012, Matthew Welland. +;; +;; This file is part of Megatest. +;; +;; Megatest is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. +;; +;; Megatest is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with Megatest. If not, see . + +;;====================================================================== + +;;====================================================================== +;; implementation of context menu that pops up on +;; right click on test cell in Runs & Runs Summary Tabs +;;====================================================================== + +(use format fmt) +(require-library iup) +(import (prefix iup iup:)) + +(use canvas-draw) + +(use srfi-1 posix regex regex-case srfi-69) +(use (prefix sqlite3 sqlite3:)) + +(declare (unit dashboard-context-menu)) +(declare (uses common)) +(declare (uses db)) +(declare (uses gutils)) +(declare (uses rmt)) +(declare (uses ezsteps)) +;; (declare (uses sdb)) +;; (declare (uses filedb)) +(declare (uses subrun)) + +(include "common_records.scm") +(include "db_records.scm") +(include "run_records.scm") + +(define (dboard:launch-testpanel run-id test-id) + (let* ((dboardexe (common:find-local-megatest "dashboard")) + (cmd (conc dboardexe + " -test " run-id "," test-id + " &"))) + (system cmd))) + + +(define (dashboard:run-menu-items run-id test-id target runname test-name testpatt item-test-path test-info) + (list + (iup:menu-item + (conc "Rerun " testpatt) + #:action + (lambda (obj) + ;; (print " run-id: " run-id " test-id: " test-id " target: " target " runname: " runname " test-name: " test-name " testpatt: " testpatt "item-path : " item-path) + (common:run-a-command + (conc "megatest -run -target " target + " -runname " runname + " -testpatt " testpatt + " -preclean -clean-cache") + ))) + (iup:menu-item + "Rerun Complete Run" + #:action + (lambda (obj) + (common:run-a-command + (conc "megatest -set-state-status NOT_STARTED,n/a -run -target " target + " -runname " runname + " -testpatt % " + " -preclean -clean-cache")))) + (iup:menu-item + "Clean Complete Run" + #:action + (lambda (obj) + (common:run-a-command + (conc "megatest -remove-runs -target " target + " -runname " runname + " -testpatt % ")))) + (iup:menu-item + "Kill Complete Run" + #:action + (lambda (obj) + (common:run-a-command + (conc "megatest -set-state-status KILLREQ,n/a -target " target + " -runname " runname + " -testpatt % " + " -state RUNNING,REMOTEHOSTSTART,LAUNCHED,NOT_STARTED")))) + (iup:menu-item + "Delete Run Data" + #:action + (lambda (obj) + (common:run-a-command + (conc "megatest -remove-runs -target " target + " -runname " runname + " -testpatt % " + " -keep-records")))))) + +(define (dashboard:test-menu-items run-id test-id target runname test-name testpatt item-test-path test-info) + (list + (iup:menu-item + (conc "Rerun " item-test-path) + #:action + (lambda (obj) + (common:run-a-command + (conc "megatest -set-state-status NOT_STARTED,n/a -run -target " target + " -runname " runname + " -testpatt " item-test-path + " -preclean -clean-cache")))) + (iup:menu-item + (conc "Kill " item-test-path) + #:action + (lambda (obj) + ;; (rmt:test-set-state-status-by-id run-id test-id "KILLREQ" #f #f) + (common:run-a-command + (conc "megatest -set-state-status KILLREQ,n/a -target " target + " -runname " runname + " -testpatt " item-test-path + " -state RUNNING,REMOTEHOSTSTART,LAUNCHED")))) + (iup:menu-item + (conc "Delete data : " item-test-path) + #:action + (lambda (obj) + (common:run-a-command + (conc "megatest -remove-runs -target " target + " -runname " runname + " -testpatt " item-test-path + " -keep-records")))) + (iup:menu-item + (conc "Clean "item-test-path) + #:action + (lambda (obj) + (common:run-a-command + (conc "megatest -remove-runs -target " target + " -runname " runname + " -testpatt " item-test-path)))) + (iup:menu-item + "Start xterm" + #:action + (lambda (obj) + (dcommon:examine-xterm run-id test-id))) + ;;(let* ((cmd (conc (car (argv)) " -xterm " run-id "," test-id "&"))) + ;; (system cmd)))) + (iup:menu-item + "Edit testconfig" + #:action + (lambda (obj) + (let* ((all-tests (tests:get-all)) + (editor-rx (or (configf:lookup *configdat* "setup" "editor-regex") + "\\b(vim?|nano|pico)\\b")) + (editor (or (configf:lookup *configdat* "setup" "editor") + (get-environment-variable "VISUAL") + (get-environment-variable "EDITOR") "vi")) + (tconfig (conc (hash-table-ref all-tests test-name) "/testconfig")) + (cmd (conc (if (string-search editor-rx editor) + (conc "xterm -e " editor) + editor) + " " tconfig " &"))) + (system cmd)))))) + +(define (dashboard:step-logs-menu-item run-id test-id target runname test-name testpatt item-test-path test-info) + (let* ((steps (tests:get-compressed-steps run-id test-id)) ;; # + (rundir (db:test-get-rundir test-info))) + + (iup:menu-item + "Step logs" + (apply iup:menu + (map (lambda (step) + (let ((stepname (vector-ref step 0)) + (logfile (vector-ref step 5)) + (status (vector-ref step 3))) + (iup:menu-item + (conc stepname "/" (if (string=? logfile "") "no log!" logfile) " (" status ")") + #:action (lambda (obj) + (let ((fullfile (conc rundir "/" logfile))) + (if (common:file-exists? fullfile) + (dcommon:run-html-viewer fullfile) + (message-window (conc "file " fullfile " not found")))))))) + steps))))) + +(define (dashboard:toplevel-menu-items run-id test-id target runname test-name testpatt item-test-path test-info) + (list + + (iup:menu-item + "Test Control Panel" + #:action + (lambda (obj) + (dboard:launch-testpanel run-id test-id))) + + (dashboard:step-logs-menu-item run-id test-id target runname test-name testpatt item-test-path test-info) + + (iup:menu-item + (conc "Rerun " item-test-path) + #:action + (lambda (obj) + (common:run-a-command + (conc "megatest -set-state-status NOT_STARTED,n/a -run -target " target + " -runname " runname + " -testpatt " item-test-path + " -preclean -clean-cache")))) + + (iup:menu-item + "Start xterm" + #:action + (lambda (obj) + (dcommon:examine-xterm run-id test-id))) + + (iup:menu-item + (conc "Kill " item-test-path) + #:action + (lambda (obj) + ;; (rmt:test-set-state-status-by-id run-id test-id "KILLREQ" #f #f) + (common:run-a-command + (conc "megatest -set-state-status KILLREQ,n/a -target " target + " -runname " runname + " -testpatt " item-test-path + " -state RUNNING,REMOTEHOSTSTART,LAUNCHED,NOT_STARTED")))) + + (let* ((rundir (db:test-get-rundir test-info)) + (has-subrun (subrun:subrun-test-initialized? rundir))) + (if has-subrun + (iup:menu-item + "Launch subrun dashboard" + #:action + (lambda (obj) + (subrun:launch-dashboard rundir))) + (iup:vbox))) + + (iup:menu-item + (conc "View Log " item-test-path) + #:action + (lambda (obj) + (let* ((rundir (db:test-get-rundir test-info)) + (logf (db:test-get-final_logf test-info)) + (fullfile (conc rundir "/" logf))) + (if (common:file-exists? fullfile) + (dcommon:run-html-viewer fullfile) + (message-window (conc "file " fullfile " not found."))))) + ) + )) +;; example section for megatest.config: +;; +;; +;; [custom-context-menu-items] +;; # : +;; item1 custom show run-id (%run-id%):echo "%run-id%" +;; item2 custom show test-id (%test-id%):echo "%test-id%" +;; item3 custom show target (%target%):echo "%target%" +;; item4 custom show test-name (%test-name%):echo "%test-name%" +;; item5 custom show test-patt (%test-patt%):echo "%test-patt%" +;; item6 custom show test-run-dir (%test-run-dir%):echo "%test-run-dir%" +;; item7 custom show run-area-home (%run-area-home%):echo "%run-area-home%" +;; item8 custom show megatest root (%mt-root%):echo "%mt-root%" +;; item9 custom ls : ls -lrt +;; item10 custom see $MT_RUN_AREA_HOME (not yet implemented) : echo $MT_RUN_AREA_HOME + +(define (dashboard:custom-menu-items run-id test-id target run-name test-name testpatt item-test-path test-info) + (let* ((vars (configf:section-vars *configdat* "custom-context-menu-items")) + (item-path (db:test-get-item-path test-info)) + (mt-root (pathname-directory (pathname-directory *common:this-exe-dir* )))) + (filter-map + (lambda (var) + (let* ((val (configf:lookup *configdat* "custom-context-menu-items" var)) + (m (string-match "^\\s*([^:]+?)\\s*:\\s*(.*?)\\s*$" val))) + (if m + (let* ((menu-item-text-raw (list-ref m 1)) + (command-line-raw (list-ref m 2)) + (subst-alist ;; template vars + `(( "%run-id%" . ,run-id ) + ( "%test-id%" . ,test-id ) + ( "%target%" . ,target ) + ( "%test-name%" . ,test-name) + ( "%test-patt%" . ,testpatt) + ( "%test-run-dir%" . ,(db:test-get-rundir test-info)) + ( "%mt-root%" . ,mt-root) + ( "%run-name%" . ,run-name) + ( "%run-area-home%" . ,*toppath*) + ( "%item-path%" . ,item-path) + ( "%item-test-patt%" . ,item-test-path ))) + (command-line ;; replace template vars + (foldr + (lambda (x i) + (string-substitute + (car x) + (->string (cdr x)) + i + #t)) + command-line-raw + subst-alist)) + (menu-item-text ;; replace template vars + (foldr + (lambda (x i) + (string-substitute + (car x) + (->string (cdr x)) + i + #t)) + menu-item-text-raw + subst-alist))) + (iup:menu-item + (conc "*"menu-item-text) + #:action + (lambda (obj) + + (let* ((scheme-match (string-match "^#(\\(.*)" command-line))) + ;;(BB> "cmdline is >"command-line"<") + (common:with-env-vars + ;; TODO: with-env-vars + ;; TODO: with-env-vars MT_* + (runs:get-mt-env-alist run-id run-name target test-name item-path) + + (lambda () + (if scheme-match + (begin + (handle-exceptions + exn + (print "error with custom menu scheme, exn=" exn) + (begin + ;;(BB> "gonna eval it!") + (eval (with-input-from-string (cadr scheme-match) read))))) + (common:run-a-command command-line with-vars: #t)))))))) + #f))) + vars))) + +(define (dashboard:context-menu run-id test-id target runname test-name testpatt item-test-path test-info) + (let* ((run-menu-items + (dashboard:run-menu-items run-id test-id target runname test-name testpatt item-test-path test-info)) + (test-menu-items + (dashboard:test-menu-items run-id test-id target runname test-name testpatt item-test-path test-info)) + (custom-menu-items + (dashboard:custom-menu-items run-id test-id target runname test-name testpatt item-test-path test-info)) + (toplevel-menu-items + (dashboard:toplevel-menu-items run-id test-id target runname test-name testpatt item-test-path test-info)) + ) + (apply iup:menu + `(,@toplevel-menu-items + ,(iup:menu-item + "Run" + (apply iup:menu run-menu-items)) + ,(iup:menu-item + "Test" + (apply iup:menu test-menu-items)) + ,@custom-menu-items)))) Index: dashboard-guimonitor.scm ================================================================== --- dashboard-guimonitor.scm +++ dashboard-guimonitor.scm @@ -1,14 +1,23 @@ ;;====================================================================== ;; Copyright 2006-2012, Matthew Welland. ;; -;; This program is made available under the GNU GPL version 2.0 or -;; greater. See the accompanying file COPYING for details. +;; This file is part of Megatest. +;; +;; Megatest is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. +;; +;; Megatest is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. ;; -;; This program is distributed WITHOUT ANY WARRANTY; without even the -;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR -;; PURPOSE. +;; You should have received a copy of the GNU General Public License +;; along with Megatest. If not, see . +;; ;;====================================================================== ;;====================================================================== ;; Test info panel ;;====================================================================== Index: dashboard-tests.scm ================================================================== --- dashboard-tests.scm +++ dashboard-tests.scm @@ -1,14 +1,23 @@ ;;====================================================================== ;; Copyright 2006-2012, Matthew Welland. ;; -;; This program is made available under the GNU GPL version 2.0 or -;; greater. See the accompanying file COPYING for details. +;; This file is part of Megatest. +;; +;; Megatest is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. +;; +;; Megatest is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. ;; -;; This program is distributed WITHOUT ANY WARRANTY; without even the -;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR -;; PURPOSE. +;; You should have received a copy of the GNU General Public License +;; along with Megatest. If not, see . + ;;====================================================================== ;;====================================================================== ;; Test info panel ;;====================================================================== @@ -17,21 +26,22 @@ (require-library iup) (import (prefix iup iup:)) (use canvas-draw) -(use sqlite3 srfi-1 posix regex regex-case srfi-69) -(import (prefix sqlite3 sqlite3:)) +(use srfi-1 posix regex regex-case srfi-69) +(use (prefix sqlite3 sqlite3:)) (declare (unit dashboard-tests)) (declare (uses common)) (declare (uses db)) (declare (uses gutils)) (declare (uses rmt)) (declare (uses ezsteps)) ;; (declare (uses sdb)) ;; (declare (uses filedb)) +(declare (uses subrun)) (include "common_records.scm") (include "db_records.scm") (include "run_records.scm") @@ -39,17 +49,33 @@ ;; C O M M O N ;;====================================================================== (define *dashboard-comment-share-slot* #f) +(define (message-window msg) + (iup:show + (iup:dialog + (iup:vbox + (iup:label msg #:margin "40x40"))))) + (define (dtests:get-pre-command #!key (default-override #f)) - (let ((cfg-ovrd (configf:lookup *configdat* "dashboard" "pre-command"))) - (or cfg-ovrd default-override "xterm -geometry 180x20 -e \""))) + (let* ((orig-pre-command "export CMD='") + (viewscreen-pre-command "viewscreen ") + (use-viewscreen (configf:lookup *configdat* "dashboard" "use-viewscreen")) + (default-pre-command (if use-viewscreen viewscreen-pre-command orig-pre-command)) + (cfg-ovrd (configf:lookup *configdat* "dashboard" "pre-command"))) + (or cfg-ovrd default-override default-pre-command))) ;; "xterm -geometry 180x20 -e \"")) + (define (dtests:get-post-command #!key (default-override #f)) - (let ((cfg-ovrd (configf:lookup *configdat* "dashboard" "post-command"))) - (or cfg-ovrd default-override ";echo Press any key to continue;bash -c 'read -n 1 -s'\" &"))) + (let* ((orig-post-command (conc "';xterm -geometry 180x20 -e \"(echo; echo -n START:;date +ww%U.%w-$H:%M:%S;echo;echo $CMD;echo;$CMD)|&" + "tee -a runlog-`date +ww%U.%w-%H:%M`.log;echo Press any key to continue;bash -c 'read -n 1 -s'\" &")) + (viewscreen-post-command "") + (use-viewscreen (configf:lookup *configdat* "dashboard" "use-viewscreen")) + (default-post-command (if use-viewscreen viewscreen-post-command orig-post-command)) + (cfg-ovrd (configf:lookup *configdat* "dashboard" "post-command"))) + (or cfg-ovrd default-override default-post-command))) ;; ";echo Press any key to continue;bash -c 'read -n 1 -s'\" &"))) (define (test-info-panel testdat store-label widgets) (iup:frame #:title "Test Info" ; #:expand "YES" @@ -158,11 +184,11 @@ ;;====================================================================== ;; Run info panel ;;====================================================================== (define (run-info-panel db keydat testdat runname) (let* ((run-id (db:test-get-run_id testdat)) - (rundat (db:get-run-info db run-id)) + (rundat (rmt:get-run-info run-id)) (header (db:get-header rundat)) (event_time (db:get-value-by-header (db:get-rows rundat) (db:get-header rundat) "event_time"))) (iup:frame @@ -233,21 +259,36 @@ ))))) ;; if there is a submegatest create a button to launch dashboard in that area ;; (define (submegatest-panel dbstruct keydat testdat runname testconfig) - (let* ((subarea (configf:lookup testconfig "setup" "submegatest")) - (area-exists (and subarea (file-exists? subarea)))) - ;; (debug:print-info 0 *default-log-port* "Megatest subarea=" subarea ", area-exists=" area-exists) - (if subarea - (iup:frame - #:title "Megatest Run Info" ; #:expand "YES" - (iup:button - "Launch Dashboard" - #:action (lambda (obj) - (system (conc "cd " subarea ";env -i PATH=$PATH DISPLAY=$DISPLAY HOME=$HOME USER=$USER dashboard &"))))) - (iup:vbox)))) + (let* ((test-run-dir (db:test-get-rundir testdat)) + (subarea (subrun:get-runarea test-run-dir)) + (area-exists (and subarea (common:file-exists? subarea silent: #t))) + (target #f) + (runname #f) + (cmd-parts-file (conc test-run-dir "/subrun-command-parts.sexp"))) + (if (file-exists? cmd-parts-file) ;; existance of this file is sufficient to *try* opening a dashboard + (let* ((cmd-parts (if (file-exists? cmd-parts-file) + (with-input-from-file cmd-parts-file + read) + '())) + (target (alist-ref "-target" cmd-parts equal?)) + (runname (alist-ref "-runname" cmd-parts equal?)) + (run-area (alist-ref "-startdir" cmd-parts equal?))) + (iup:frame + #:title "Megatest Run Info" ; #:expand "YES" + (iup:vbox + (iup:button + "Launch Dashboard" + #:action (lambda (obj) + (subrun:launch-dashboard test-run-dir))) + (iup:button + "Launch Dashboard+Filter" + #:action (lambda (obj) + (subrun:launch-dashboard test-run-dir target: target runname: runname)))))) + (iup:vbox )))) ;; use a global for setting the buttons colors ;; state status teststeps (define *state-status* (vector #f #f #f)) (define (update-state-status-buttons testdat) @@ -271,13 +312,14 @@ (iup:frame #:title "Set fields" (iup:vbox (iup:hbox (iup:label "Comment:") (let ((txtbox (iup:textbox #:action (lambda (val a b) - (rmt:test-set-state-status-by-id run-id test-id #f #f b) + ;; (rmt:test-set-state-status-by-id run-id test-id #f #f b) + (rmt:test-set-state-status run-id test-id #f #f b) ;; IDEA: Just set a variable with the proc to call? - (rmt:test-set-state-status-by-id run-id test-id #f #f b) + ;; (rmt:test-set-state-status-by-id run-id test-id #f #f b) (set! newcomment b)) #:value (db:test-get-comment testdat) #:expand "HORIZONTAL"))) (set! wtxtbox txtbox) txtbox)) @@ -286,22 +328,23 @@ (iup:label "STATE:" #:size "30x") (let* ((btns (map (lambda (state) (let ((btn (iup:button state #:expand "HORIZONTAL" #:size "50x" #:font "Courier New, -10" #:action (lambda (x) - (rmt:test-set-state-status-by-id run-id test-id state #f #f) + ;; (rmt:test-set-state-status-by-id run-id test-id state #f #f) + (rmt:set-state-status-and-roll-up-items run-id test-id #f state #f #f) ;; test-name passed in as test-id is respected (db:test-set-state! testdat state))))) btn)) (map cadr *common:std-states*)))) ;; (list "COMPLETED" "NOT_STARTED" "RUNNING" "REMOTEHOSTSTART" "LAUNCHED" "KILLED" "KILLREQ")))) (vector-set! *state-status* 0 (lambda (state color) (for-each (lambda (btn) (let* ((name (iup:attribute btn "TITLE")) (newcolor (if (equal? name state) color "192 192 192"))) - (if (not (colors-similar? newcolor (iup:attribute btn "BGCOLOR"))) - (iup:attribute-set! btn "BGCOLOR" newcolor)))) + (if (not (colors-similar? newcolor (iup:attribute btn "FGCOLOR"))) + (iup:attribute-set! btn "FGCOLOR" newcolor)))) btns))) btns)) (apply iup:hbox (iup:label "STATUS:" #:size "30x") (let* ((btns (map (lambda (status) @@ -319,58 +362,72 @@ (iup:attribute-set! wtxtbox "VALUE" c) (if (not *dashboard-comment-share-slot*) (set! *dashboard-comment-share-slot* wtxtbox))) )))) (begin - (rmt:test-set-state-status-by-id run-id test-id #f status #f) + ;; (rmt:test-set-state-status-by-id run-id test-id #f status #f) + (rmt:set-state-status-and-roll-up-items run-id test-id #f #f status #f) ;; test-name passed in as test-id is respected (db:test-set-status! testdat status)))))))) btn)) (map cadr *common:std-statuses*)))) ;; (list "PASS" "WARN" "FAIL" "CHECK" "n/a" "WAIVED" "SKIP")))) (vector-set! *state-status* 1 (lambda (status color) (for-each (lambda (btn) (let* ((name (iup:attribute btn "TITLE")) (newcolor (if (equal? name status) color "192 192 192"))) - (if (not (colors-similar? newcolor (iup:attribute btn "BGCOLOR"))) - (iup:attribute-set! btn "BGCOLOR" newcolor)))) + (if (not (colors-similar? newcolor (iup:attribute btn "FGCOLOR"))) + (iup:attribute-set! btn "FGCOLOR" newcolor)))) btns))) btns)))))) -(define (dashboard-tests:run-html-viewer lfilename) - (let ((htmlviewercmd (configf:lookup *configdat* "setup" "htmlviewercmd"))) - (if htmlviewercmd - (system (conc "(" htmlviewercmd " " lfilename " ) &")) - (iup:send-url lfilename)))) - (define (dashboard-tests:run-a-step info) #t) -(define (dashboard-tests:step-run-control testdat stepname testconfig) - (iup:dialog ;; #:close_cb (lambda (a)(exit)) ; #:expand "YES" - #:title stepname - (iup:vbox ; #:expand "YES" - (iup:label (conc "Step: " stepname "\nNB// These buttons only run the test step\nfor the purpose of debugging.\nNot all database updates are done.")) - (iup:button "Re-run" - #:expand "HORIZONTAL" - #:action (lambda (obj) - (thread-start! - (make-thread (lambda () - (ezsteps:run-from testdat stepname #t)) - (conc "ezstep run single step " stepname))))) - (iup:button "Re-run and continue" - #:expand "HORIZONTAL" - #:action (lambda (obj) - (thread-start! - (make-thread (lambda () - (ezsteps:run-from testdat stepname #f)) - (conc "ezstep run from step " stepname))))) - ;; (iup:button "Refresh test data" - ;; #:expand "HORIZONTAL" - ;; #:action (lambda (obj) - ;; (print "Refresh test data " stepname)) - ))) +;; (define (dashboard-tests:step-run-control testdat stepname testconfig) +;; (let* ((mutex (make-mutex))) +;; (letrec ((dlg +;; (iup:dialog ;; #:close_cb (lambda (a)(exit)) ; #:expand "YES" +;; #:title stepname +;; (iup:vbox ; #:expand "YES" +;; (iup:label (conc "Step: " stepname "\nNB// These buttons only run the test step\nfor the purpose of debugging.\nNot all database updates are done.")) +;; (iup:button "Re-run" +;; #:expand "HORIZONTAL" +;; #:action (lambda (obj) +;; (debug:catch-and-dump (lambda () +;; (thread-start! +;; (make-thread +;; (lambda () +;; (print "BB> started ezsteps:run-from") +;; (debug:catch-and-dump +;; (lambda () +;; (ezsteps:run-from testdat stepname #t)) +;; "dashboard-tests:step-run-control -> ezstep:run-from (1)") +;; (print "BB> done ezsteps:run-from") +;; 'foo) +;; (conc "ezstep run single step " stepname))) +;; ) +;; "step-run-control action"))) +;; (iup:button "Re-run and continue" +;; #:expand "HORIZONTAL" +;; #:action (lambda (obj) +;; (debug:catch-and-dump +;; (lambda () +;; (thread-start! +;; (make-thread (lambda () +;; (ezsteps:run-from testdat stepname #f)) +;; (conc "ezstep run from step " stepname)))) +;; "dashboard-tests:step-run-control -> ezstep:run-from (2)"))) +;; (iup:button "Close" +;; #:action (lambda (obj) +;; (iup:destroy! dlg))) +;; ;; (iup:button "Refresh test data" +;; ;; #:expand "HORIZONTAL" +;; ;; #:action (lambda (obj) +;; ;; (print "Refresh test data " stepname)) +;; )))) +;; dlg))) (define (dashboard-tests:waiver run-id testdat ovrdval cmtcmd) (let* ((wpatt (configf:lookup *configdat* "setup" "waivercommentpatt")) (wregx (if (string? wpatt)(regexp wpatt) #f)) (wmesg (iup:label (if wpatt (conc "Comment must match pattern " wpatt) ""))) @@ -400,11 +457,12 @@ (let ((comment (iup:attribute comnt "VALUE")) (test-id (db:test-get-id testdat))) (if (or (not wpatt) (string-match wregx comment)) (begin - (rmt:test-set-state-status-by-id run-id test-id #f "WAIVED" comment) + ;; (rmt:test-set-state-status-by-id run-id test-id #f "WAIVED" comment) + (rmt:test-set-state-status run-id test-id #f "WAIVED" comment) (db:test-set-status! testdat "WAIVED") (cmtcmd comment) (iup:destroy! dlog)))))) (iup:button "Cancel" #:expand "HORIZONTAL" @@ -414,14 +472,14 @@ ;;====================================================================== ;; ;;====================================================================== -(define (examine-test run-id test-id) ;; run-id run-key origtest) - (let* ((db-path (db:dbfile-path run-id)) ;; (conc (configf:lookup *configdat* "setup" "linktree") "/db/" run-id ".db")) - (dbstruct (make-dbr:dbstruct path: (db:dbfile-path #f) ;; (configf:lookup *configdat* "setup" "linktree") - local: #t)) +(define (dashboard-tests:examine-test run-id test-id) ;; run-id run-key origtest) + (let* ((db-path (db:dbfile-path)) ;; (conc (configf:lookup *configdat* "setup" "linktree") "/db/" run-id ".db")) + (dbstruct #f) ;; NOT ACTUALLY USED (db:setup)) ;; (make-dbr:dbstruct path: (db:dbfile-path #f) ;; (configf:lookup *configdat* "setup" "linktree") + ;; local: #t)) (testdat (rmt:get-test-info-by-id run-id test-id)) ;; (db:get-test-info-by-id dbstruct run-id test-id)) (db-mod-time 0) ;; (file-modification-time db-path)) (last-update 0) ;; (current-seconds)) (request-update #t)) (if (not testdat) @@ -441,11 +499,19 @@ (logfile "/this/dir/better/not/exist") (rundir (if testdat (db:test-get-rundir testdat) logfile)) ;; (testdat-path (conc rundir "/testdat.db")) ;; this gets recalculated until found - (teststeps (if testdat (tests:get-compressed-steps run-id test-id) '())) + (augment-teststeps (lambda (inlov) + (map + (lambda (invec) + (list->vector + `( + ,@(reverse (cdr (reverse (vector->list invec)))) + "rerun this step" "restart from here" ))) + inlov))) + (teststeps (if testdat (augment-teststeps (tests:get-compressed-steps run-id test-id)) '())) (testfullname (if testdat (db:test-get-fullname testdat) "Gathering data ...")) (testname (if testdat (db:test-get-testname testdat) "n/a")) ;; (tests:get-testconfig testdat testname 'return-procs)) (testmeta (if testdat (let ((tm (rmt:testmeta-get-record testname))) @@ -459,35 +525,39 @@ keydat) "/")) (item-path (db:test-get-item-path testdat)) ;; this next block was added to fix a bug where variables were ;; needed. Revisit this. - (runconfig (let ((runconfigf (conc *toppath* "/runconfigs.config"))) - (if (file-exists? runconfigf) + (runconfig (let ((runconfigf (conc *toppath* "/runconfigs.config"))) ;; no rush but it would be good to convert this call to use runconfig:read + (if (common:file-exists? runconfigf) (handle-exceptions - exn - #f ;; do nothing, just keep on trucking .... + exn + (begin + (debug:print 0 *default-log-port* "failed to set up environment for " runconfigf ", exn=" exn) + #f) ;; do nothing, just keep on trucking .... (setup-env-defaults runconfigf run-id (make-hash-table) keydat environ-patt: keystring)) (make-hash-table)))) (testconfig (begin ;; (runs:set-megatest-env-vars run-id inrunname: runname testname: test-name itempath: item-path) (runs:set-megatest-env-vars run-id inkeyvals: keydat inrunname: runname intarget: keystring testname: testname itempath: item-path) ;; these may be needed by the launching process (handle-exceptions - exn - (tests:get-testconfig (db:test-get-testname testdat) test-registry #f) - (tests:get-testconfig (db:test-get-testname testdat) test-registry #t)))) + exn ;; NOTE: I've no idea why this was written this way. Research, study and fix needed! + (begin + (debug:print 0 *default-log-port* "testconfig load using " item-path " failed, trying " (db:test-get-item-path testdat) ", exn=" exn) + (tests:get-testconfig (db:test-get-testname testdat) (db:test-get-item-path testdat) test-registry #f allow-write-cache: #f)) + (tests:get-testconfig (db:test-get-testname testdat) item-path test-registry #t allow-write-cache: #f)))) (viewlog (lambda (x) - (if (file-exists? logfile) + (if (common:file-exists? logfile) ;(system (conc "firefox " logfile "&")) - (dashboard-tests:run-html-viewer logfile) + (dcommon:run-html-viewer logfile) (message-window (conc "File " logfile " not found"))))) (view-a-log (lambda (lfile) (let ((lfilename (conc rundir "/" lfile))) ;; (print "lfilename: " lfilename) - (if (file-exists? lfilename) + (if (common:file-exists? lfilename) ;(system (conc "firefox " logfile "&")) - (dashboard-tests:run-html-viewer lfilename) + (dcommon:run-html-viewer lfilename) (message-window (conc "File " lfilename " not found")))))) (xterm (lambda (x) (if (directory-exists? rundir) (let ((shell (if (get-environment-variable "SHELL") (conc "-e " (get-environment-variable "SHELL")) @@ -498,11 +568,11 @@ "MT_.*")) (message-window (conc "Directory " rundir " not found"))))) (widgets (make-hash-table)) (refreshdat (lambda () (let* ((curr-mod-time (file-modification-time db-path)) - ;; (max ..... (if (file-exists? testdat-path) + ;; (max ..... (if (common:file-exists? testdat-path) ;; (file-modification-time testdat-path) ;; (begin ;; (set! testdat-path (conc rundir "/testdat.db")) ;; 0)))) (need-update (or (and (>= curr-mod-time db-mod-time) @@ -510,18 +580,21 @@ (> (current-milliseconds)(+ last-update 10000)) ;; force update even 10 seconds request-update)) (newtestdat (if need-update ;; NOTE: BUG HIDER, try to eliminate this exception handler (handle-exceptions - exn - (debug:print-info 0 *default-log-port* "test db access issue in examine test for run-id " run-id ", test-id " test-id ": " ((condition-property-accessor 'exn 'message) exn)) - (rmt:get-test-info-by-id run-id test-id ))))) - ;; (debug:print-info 0 *default-log-port* "need-update= " need-update " curr-mod-time = " curr-mod-time) + exn + (begin + (debug:print-info 0 *default-log-port* "test db access issue in examine test for run-id " run-id + ", test-id " test-id ": " ((condition-property-accessor 'exn 'message) exn) ", exn=" exn) + #f) + (rmt:get-test-info-by-id run-id test-id))))) + ;; (print "INFO: need-update= " need-update " curr-mod-time = " curr-mod-time) (cond ((and need-update newtestdat) (set! testdat newtestdat) - (set! teststeps (tests:get-compressed-steps run-id test-id)) + (set! teststeps (augment-teststeps (tests:get-compressed-steps run-id test-id))) (set! logfile (conc (db:test-get-rundir testdat) "/" (db:test-get-final_logf testdat))) (set! rundir ;; (filedb:get-path *fdb* (db:test-get-rundir testdat)) ;; ) (set! testfullname (db:test-get-fullname testdat)) ;; (debug:print 0 *default-log-port* "INFO: teststeps=" (intersperse teststeps "\n ")) @@ -576,18 +649,18 @@ ))))) lbl)) (store-button store-label) (command-proc (lambda (command-text-box) (let* ((cmd (iup:attribute command-text-box "VALUE"))) - (common:run-a-command cmd)))) + (common:run-a-command cmd with-orig-env: #t)))) (command-text-box (iup:textbox #:expand "HORIZONTAL" #:font "Courier New, -10" #:action (lambda (obj cnum val) ;; (print "cnum=" cnum) (if (eq? cnum 13) - (command-prox obj))) + (command-proc obj))) )) (command-launch-button (iup:button "Execute!" #:action (lambda (x) (command-proc command-text-box)))) ;; (lambda (x) ;; (let* ((cmd (iup:attribute command-text-box "VALUE")) @@ -618,25 +691,24 @@ " -testpatt " (conc testname "/" (if (equal? item-path "") "%" item-path)) " -v")))) (clean-run-execute (lambda (x) - (let ((cmd (conc "megatest -remove-runs -target " keystring " -runname " runname + (let ((cmd (conc ;; "megatest -remove-runs -target " keystring " -runname " runname + "megatest -set-state-status NOT_STARTED,n/a -target " keystring " -runname " runname " -testpatt " (conc testname "/" (if (equal? item-path "") "%" item-path)) - ";megatest -target " keystring " -runname " runname + ";megatest -target " keystring " -runname " runname " -run -preclean -testpatt " (conc testname "/" (if (equal? item-path "") "%" item-path)) " -clean-cache" ))) - (common:without-vars - (conc (dtests:get-pre-command) - cmd - (dtests:get-post-command)) - "MT_.*")))) + (thread-start! (make-thread (lambda () + (common:run-a-command cmd)) + "clean-run-execute"))))) (remove-test (lambda (x) (iup:attribute-set! command-text-box "VALUE" (conc "megatest -remove-runs -target " keystring " -runname " runname " -testpatt " (conc testname "/" (if (equal? item-path "") @@ -689,25 +761,25 @@ ;; Replace here with matrix (let ((steps-matrix (iup:matrix #:font "Courier New, -8" #:expand "YES" #:scrollbar "YES" - #:numcol 7 + #:numcol 9 #:numlin 100 - #:numcol-visible 7 + #:numcol-visible 9 #:numlin-visible 5 #:click-cb (lambda (obj lin col status) ;; (if (equal? col 6) - (let* ((mtrx-rc (conc lin ":" 6)) - (fname (iup:attribute obj mtrx-rc))) ;; col)))) - (if (eq? col 6) - (view-a-log fname) - (iup:show - (dashboard-tests:step-run-control - testdat - (iup:attribute obj (conc lin ":" 1)) - teststeps)))))))) + (let* ((mtrx-rc (conc lin ":" 6)) + (fname (iup:attribute obj mtrx-rc)) + (stepname (iup:attribute obj (conc lin ":" 1))) (comment (iup:attribute obj (conc lin ":" 7)))) + (case col + + ((7) (print "Comment from step "stepname": "comment)) + ((8) (ezsteps:spawn-run-from testdat stepname #t)) + ((9) (ezsteps:spawn-run-from testdat stepname #f)) + (else (view-a-log fname)))))))) ;; (let loop ((count 0)) ;; (iup:attribute-set! steps-matrix "FITTOTEXT" (conc "L" count)) ;; (if (< count 30) ;; (loop (+ count 1)))) (iup:attribute-set! steps-matrix "0:1" "Step Name") @@ -717,16 +789,21 @@ (iup:attribute-set! steps-matrix "0:4" "Status") (iup:attribute-set! steps-matrix "WIDTH4" "50") (iup:attribute-set! steps-matrix "0:5" "Duration") (iup:attribute-set! steps-matrix "0:6" "Log File") (iup:attribute-set! steps-matrix "0:7" "Comment") + (iup:attribute-set! steps-matrix "0:8" "rerun only") + (iup:attribute-set! steps-matrix "BGCOLOR0:9" "149 208 252") + (iup:attribute-set! steps-matrix "BGCOLOR0:8" "149 208 252") + (iup:attribute-set! steps-matrix "BGCOLOR0:7" "149 208 252") + (iup:attribute-set! steps-matrix "0:9" "rerun & continue") (iup:attribute-set! steps-matrix "ALIGNMENT1" "ALEFT") ;; (iup:attribute-set! steps-matrix "FIXTOTEXT" "C1") (iup:attribute-set! steps-matrix "RESIZEMATRIX" "YES") (let ((proc (lambda (testdat) - (dcommon:populate-steps teststeps steps-matrix)))) + (dcommon:populate-steps teststeps steps-matrix run-id test-id)))) (hash-table-set! widgets "StepsMatrix" proc) (proc testdat)) steps-matrix) ;; populate the Test Data panel (iup:frame @@ -774,6 +851,112 @@ ;; Now start keeping the gui updated from the db (refreshdat) ;; update from the db here ;(thread-suspend! other-thread) (if *exit-started* (set! *exit-started* 'ok)))))))))) + +(define (colors-similar? color1 color2) + (let* ((c1 (map string->number (string-split color1))) + (c2 (map string->number (string-split color2))) + (delta (map (lambda (a b)(abs (- a b))) c1 c2))) + (null? (filter (lambda (x)(> x 3)) delta)))) + +;; Display the tests as rows of boxes on the test/task pane +;; +(define (dashboard:draw-tests cnv xadj yadj tests-draw-state sorted-testnames test-records) + (canvas-clear! cnv) + (canvas-font-set! cnv "Helvetica, -10") + (let-values (((sizex sizey sizexmm sizeymm) (canvas-size cnv)) + ((originx originy) (canvas-origin cnv))) + ;; (print "originx: " originx " originy: " originy) + ;; (canvas-origin-set! cnv 0 (- (/ sizey 2))) + (if (hash-table-ref/default tests-draw-state 'first-time #t) + (begin + (hash-table-set! tests-draw-state 'first-time #f) + (hash-table-set! tests-draw-state 'scalef 1) + (hash-table-set! tests-draw-state 'tests-info (make-hash-table)) + (hash-table-set! tests-draw-state 'selected-tests (make-hash-table)) + ;; set these + (dcommon:initial-draw-tests cnv xadj yadj sizex sizey sizexmm sizeymm originx originy tests-draw-state sorted-testnames test-records)) + (dcommon:redraw-tests cnv xadj yadj sizex sizey sizexmm sizeymm originx originy tests-draw-state sorted-testnames test-records)) + )) + +(define (dboard:tabdat-test-patts-use vec) + (let ((val (dboard:tabdat-test-patts vec)))(if val val ""))) ;;RADT => What is the if for? + +;; additional setters for dboard:data +(define (dboard:tabdat-test-patts-set!-use vec val) + (dboard:tabdat-test-patts-set! vec (if (equal? val "") #f val))) + +;; Extract the various bits of data from tabdat and create the command line equivalent that will be displayed +;; +(define (dashboard:update-run-command tabdat) + (let* ((cmd-tb (dboard:tabdat-command-tb tabdat)) + (cmd (dboard:tabdat-command tabdat)) + (test-patt (let ((tp (dboard:tabdat-test-patts tabdat))) + (if (or (not tp) + (equal? tp "")) + "%" + tp))) + (states (dboard:tabdat-states tabdat)) + (statuses (dboard:tabdat-statuses tabdat)) + (target (let ((targ-list (dboard:tabdat-target tabdat))) + (if targ-list (string-intersperse targ-list "/") "no-target-selected"))) + (run-name (dboard:tabdat-run-name tabdat)) + (states-str (if (or (not states) + (null? states)) + "" + (conc " -state " (string-intersperse states ",")))) + (statuses-str (if (or (not statuses) + (null? statuses)) + "" + (conc " -status " (string-intersperse statuses ",")))) + (full-cmd "megatest")) + (case (string->symbol cmd) + ((run) + (set! full-cmd (conc full-cmd + " -run" + " -testpatt " + test-patt + " -target " + target + " -runname " + run-name + " -clean-cache" + ))) + ((remove-runs) + (set! full-cmd (conc full-cmd + " -remove-runs -runname " + run-name + " -target " + target + " -testpatt " + test-patt + states-str + statuses-str + ))) + (else (set! full-cmd " no valid command "))) + (iup:attribute-set! cmd-tb "VALUE" full-cmd))) + +(define (iuplistbox-fill-list lb items #!key (selected-item #f)) + (let ((i 1)) + (for-each (lambda (item) + (iup:attribute-set! lb (number->string i) item) + (if selected-item + (if (equal? selected-item item) + (iup:attribute-set! lb "VALUE" i))) ;; (number->string i)))) + (set! i (+ i 1))) + items) + ;; (iup:attribute-set! lb "VALUE" (if selected-item selected-item "")) + i)) + +;; if tab-num passed in then use it, otherwise look in commondat at curr-tab-num +;; adds the updater passed in the updaters list at that hashkey +;; +(define (dboard:commondat-add-updater commondat updater #!key (tab-num #f)) + (let* ((tnum (or tab-num + (dboard:commondat-curr-tab-num commondat))) + (curr-updaters (hash-table-ref/default (dboard:commondat-updaters commondat) tnum '()))) + (hash-table-set! (dboard:commondat-updaters commondat) + tnum + (cons updater curr-updaters)))) Index: dashboard.scm ================================================================== --- dashboard.scm +++ dashboard.scm @@ -1,24 +1,33 @@ ;;====================================================================== ;; Copyright 2006-2016, Matthew Welland. ;; -;; This program is made available under the GNU GPL version 2.0 or -;; greater. See the accompanying file COPYING for details. +;; This file is part of Megatest. +;; +;; Megatest is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. +;; +;; Megatest is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. ;; -;; This program is distributed WITHOUT ANY WARRANTY; without even the -;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR -;; PURPOSE. +;; You should have received a copy of the GNU General Public License +;; along with Megatest. If not, see . +;; ;;====================================================================== (use format) (require-library iup) (import (prefix iup iup:)) (use canvas-draw) (import canvas-draw-iup) - +(use ducttape-lib) (use sqlite3 srfi-1 posix regex regex-case srfi-69 typed-records sparse-vectors) ;; defstruct (import (prefix sqlite3 sqlite3:)) (declare (uses common)) (declare (uses margs)) @@ -31,32 +40,37 @@ (declare (uses runs)) (declare (uses dashboard-tests)) (declare (uses dashboard-guimonitor)) (declare (uses tree)) (declare (uses dcommon)) +(declare (uses dashboard-context-menu)) (declare (uses vg)) - +(declare (uses subrun)) ;; (declare (uses dashboard-main)) -(declare (uses megatest-version)) (declare (uses mt)) (include "common_records.scm") (include "db_records.scm") (include "run_records.scm") (include "task_records.scm") +(include "megatest-version.scm") (include "megatest-fossil-hash.scm") (include "vg_records.scm") (define help (conc "Megatest Dashboard, documentation at http://www.kiatoa.com/fossils/megatest version " megatest-version " - license GPL, Copyright (C) Matt Welland 2012-2016 + license GPL, Copyright (C) Matt Welland 2012-2017 Usage: dashboard [options] -h : this help -test run-id,test-id : control test identified by testid -skip-version-check : skip the version check + -use-db-cache : access database via cache + -target T : prefill target filter with given target pattern + -runname R : prefill runname filter with given runname pattern + -testpatt P : prefill testpatt filter with given testpatt Misc -rows R : set number of rows -cols C : set number of columns ")) @@ -74,32 +88,94 @@ "-test" "-xterm" "-debug" "-host" "-transport" + "-start-dir" + "-target" ;; use as filter + "-runname" ;; use as filter + "-testpatt" ;; use as filter ) (list "-h" "-use-server" "-guimonitor" "-main" "-v" "-q" - "-use-local" + "-use-db-cache" "-skip-version-check" + "-repl" + "-rh5.11" ;; fix to allow running on rh5.11 + "-:p" ;; ignore the built in chicken profiling switch ) args:arg-hash 0)) + +;; check for MT_* environment variables and exit if found +(if (not (args:get-arg "-test")) + (begin + (display "Checking for MT_ vars: ") + (for-each (lambda (var) + (display " ")(display var) + (if (get-environment-variable var) + (begin + (print "ERROR: environment variable " var " is set in this terminal, this will cause you problems. Exiting now.") + (exit 1)))) + '("MT_RUN_AREA_HOME" "MT_MEGATEST" "MT_CMDINFO" "MT_TEST_RUN_DIR" "MT_LINKTREE" "MT_TESTSUITENAME")) + (print ". Done. All ok."))) + +(if (not (null? remargs)) + (begin + (print "Unrecognised arguments: " (string-intersperse remargs " ")) + (exit))) (if (args:get-arg "-h") (begin (print help) (exit))) +(if (args:get-arg "-start-dir") + (if (directory-exists? (args:get-arg "-start-dir")) + (let ((fullpath (common:real-path (args:get-arg "-start-dir")))) + (setenv "PWD" fullpath) + (change-directory fullpath)) + (begin + (debug:print-error 0 *default-log-port* "non-existant start dir " (args:get-arg "-start-dir") " specified, exiting.") + (exit 1)))) + +;; TODO: Move this inside (main) +;; (if (not (launch:setup)) (begin (print "Failed to find megatest.config, exiting") (exit 1))) + +;; deal with RH 5.11 gtk lib or iup lib missing detachbox feature +;; first check for the switch +;; +(if (or (args:get-arg "-rh5.11") + (configf:lookup *configdat* "dashboard" "no-detachbox") + (not (file-exists? "/etc/os-release"))) + (set! iup:detachbox iup:vbox)) + +(if (not (common:on-homehost?)) + (begin + (debug:print 0 *default-log-port* "WARNING: Current policy requires running dashboard on homehost: " (common:get-homehost)))) + +;; RA => Might require revert for filters +;; create a watch dog to move changes from lt/.db/*.db to megatest.db +;; +;;;(if (file-write-access? (conc *toppath* "/megatest.db")) +;;(debug:print-info 13 *default-log-port* "Before common:watchdog spawn") + +(thread-start! (make-thread common:watchdog "Watchdog thread")) +;;(debug:print-info 13 *default-log-port* "After common:watchdog spawn") +;; (if (not (args:get-arg "-use-db-cache")) +;; (begin +;; (debug:print-info 0 *default-log-port* "Forcing db-cache mode due to read-only access to megatest.db") +;; (hash-table-set! args:arg-hash "-use-db-cache" #t)));;;) +;;) ;; data common to all tabs goes here ;; (defstruct dboard:commondat ((curr-tab-num 0) : number) @@ -121,37 +197,48 @@ updaters: (make-hash-table) updating: #f hide-not-hide-tabs: #f )) +;; RA => returns the tabdat stored at hashkey passed in commondat-tabdats table (e.g. 0 gives summary) +;; (define (dboard:common-get-tabdat commondat #!key (tab-num #f)) - (hash-table-ref/default - (dboard:commondat-tabdats commondat) - (or tab-num (dboard:commondat-curr-tab-num commondat)) - #f)) + (let* ((tnum (or tab-num + (dboard:commondat-curr-tab-num commondat) + 0)) ;; tab-num value is curr-tab-num value in passed commondat + (ht (dboard:commondat-tabdats commondat)) + (res (hash-table-ref/default ht tnum #f))) + (or res + (let ((new-tabdat (dboard:tabdat-make-data))) + (hash-table-set! ht tnum new-tabdat) + new-tabdat)))) +;; RA => sets the tabdat passed to the hashkey at commondat:tabdats hash table +;; (define (dboard:common-set-tabdat! commondat tabnum tabdat) (hash-table-set! (dboard:commondat-tabdats commondat) tabnum tabdat)) -;; gets and calls updater based on curr-tab-num +;; gets and calls updater list based on curr-tab-num +;; (define (dboard:common-run-curr-updaters commondat #!key (tab-num #f)) (if (dboard:common-get-tabdat commondat tab-num: tab-num) ;; only update if there is a tabdat (let* ((tnum (or tab-num (dboard:commondat-curr-tab-num commondat))) (updaters (hash-table-ref/default (dboard:commondat-updaters commondat) tnum '()))) (debug:print 4 *default-log-port* "Found these updaters: " updaters " for tab-num: " tnum) - (for-each + (for-each ;; perform the function calls for the complete updaters list (lambda (updater) ;; (debug:print 3 *default-log-port* "Running " updater) (updater)) updaters)))) ;; if tab-num passed in then use it, otherwise look in commondat at curr-tab-num +;; adds the updater passed in the updaters list at that hashkey ;; (define (dboard:commondat-add-updater commondat updater #!key (tab-num #f)) (let* ((tnum (or tab-num (dboard:commondat-curr-tab-num commondat))) (curr-updaters (hash-table-ref/default (dboard:commondat-updaters commondat) tnum '()))) @@ -167,11 +254,13 @@ ((allruns-by-id (make-hash-table)) : hash-table) ;; hash of run-id -> dboard:rundat records ((done-runs '()) : list) ;; list of runs already drawn ((not-done-runs '()) : list) ;; list of runs not yet drawn (header #f) ;; header for decoding the run records (keys #f) ;; keys for this run (i.e. target components) - ((numruns (string->number (or (args:get-arg "-cols") "10"))) : number) ;; + ((numruns (string->number (or (args:get-arg "-cols") + (configf:lookup *configdat* "dashboard" "cols") + "8"))) : number) ;; ((tot-runs 0) : number) ((last-data-update 0) : number) ;; last time the data in allruns was updated ((last-runs-update 0) : number) ;; last time we pulled the runs info to update the tree (runs-mutex (make-mutex)) ;; use to prevent parallel access to draw objects ((run-update-times (make-hash-table)) : hash-table) ;; update times indexed by run-id @@ -183,13 +272,13 @@ ((item-test-names '()) : list) ;; list of itemized tests ((run-keys (make-hash-table)) : hash-table) (runs-matrix #f) ;; used in newdashboard ((start-run-offset 0) : number) ;; left-right slider value ((start-test-offset 0) : number) ;; up-down slider value - ((runs-btn-height (or (configf:lookup *configdat* "dashboard" "btn-height") "x14")) : string) ;; was 12 + ((runs-btn-height (or (configf:lookup *configdat* "dashboard" "btn-height") "x16")) : string) ;; was 12 ((runs-btn-fontsz (or (configf:lookup *configdat* "dashboard" "btn-fontsz") "10")) : string) ;; was 8 - ((runs-cell-width (or (configf:lookup *configdat* "dashboard" "cell-width") "60")) : string) ;; was 50 + ((runs-cell-width (or (configf:lookup *configdat* "dashboard" "cell-width") "50")) : string) ;; was 50 ((all-test-names '()) : list) ;; Canvas and drawing data (cnv #f) (cnv-obj #f) @@ -200,23 +289,33 @@ (originx #f) (originy #f) ((layout-update-ok #t) : boolean) ((compact-layout #t) : boolean) + ;; Run times layout + ;; (graph-button-box #f) ;; RA => Think it is not referenced anywhere + (graph-matrix #f) + ((graph-matrix-table (make-hash-table)) : hash-table) ;; graph-dats referenced thru graph name info + ((graph-cell-table (make-hash-table)) : hash-table) ;; graph-dats referenced thru matrix cell info + ((graph-matrix-row 1) : number) + ((graph-matrix-col 1) : number) + ;; Controls used to launch runs etc. ((command "") : string) ;; for run control this is the command being built up - (command-tb #f) + (command-tb #f) ;; widget for the type of command; run, remove-runs etc. + (test-patterns-textbox #f) ;; text box widget for editing a list of test patterns (key-listboxes #f) (key-lbs #f) run-name ;; from run name setting widget states ;; states for -state s1,s2 ... statuses ;; statuses for -status s1,s2 ... ;; Selector variables curr-run-id ;; current row to display in Run summary view + prev-run-id ;; previous runid selected before current runid was selected (used in xor-two-runs runs summary mode curr-test-ids ;; used only in dcommon:run-update which is used in newdashboard - ((filters-changed #f) : boolean) ;; to to indicate that the user changed filters for this tab + ((filters-changed #t) : boolean) ;; to indicate that the user changed filters for this tab ((last-filter-str "") : string) ;; conc the target runname and testpatt for a signature of changed filters ((hide-empty-runs #f) : boolean) ((hide-not-hide #t) : boolean) ;; toggle for hide/not hide empty runs (hide-not-hide-button #f) ((searchpatts (make-hash-table)) : hash-table) ;; @@ -224,38 +323,61 @@ ((status-ignore-hash (make-hash-table)) : hash-table) ;; hash of STATUS => #t/#f (target #f) (test-patts #f) ;; db info to file the .db files for the area + (access-mode (db:get-access-mode)) ;; use cached db or not (dbdir #f) (dbfpath #f) (dbkeys #f) - ((last-db-update 0) : number) ;; last db file timestamp + ((last-db-update (make-hash-table)) : hash-table) ;; last db file timestamp (monitor-db-path #f) ;; where to find monitor.db ro ;; is the database read-only? ;; tests data ((num-tests 10) : number) ;; total number of tests to show (used in the old runs display) ;; runs tree ((path-run-ids (make-hash-table)) : hash-table) ;; path (target / runname) => id (runs-tree #f) + ((runs-tree-ht (make-hash-table)) : hash-table) ;; track which targets added to tree (merge functionality with path-run-ids?) ;; tab data ((view-changed #t) : boolean) ((xadj 0) : number) ;; x slider number (if using canvas) ((yadj 0) : number) ;; y slider number (if using canvas) - + ;; runs-summary tab state + ((runs-summary-modes '((one-run . "Show One Run") (xor-two-runs . "XOR Two Runs") (xor-two-runs-hide-clean . "XOR; Hide Clean")) ) : list) + ((runs-summary-mode-buttons '()) : list) + ((runs-summary-mode 'one-run) : symbol) + ((runs-summary-mode-change-callbacks '()) : list) + (runs-summary-source-runname-label #f) + (runs-summary-dest-runname-label #f) + ;; runs summary view + tests-tree ;; used in newdashboard ) + +;; register tabdat with BBpp +;; this is used by BBpp (Brandon's pretty printer) to convert dboard:tabdat into a composition of lists that pp will handle +(hash-table-set! *BBpp_custom_expanders_list* TABDAT: + (cons dboard:tabdat? + (lambda (tabdat-item) + (filter + (lambda (alist-entry) + (member (car alist-entry) + '(allruns-by-id allruns))) ;; FIELDS OF INTEREST + (dboard:tabdat->alist tabdat-item))))) + + (define (dboard:tabdat-target-string vec) (let ((targ (dboard:tabdat-target vec))) (if (list? targ)(string-intersperse targ "/") "no-target-specified"))) (define (dboard:tabdat-test-patts-use vec) - (let ((val (dboard:tabdat-test-patts vec)))(if val val ""))) + (let ((val (dboard:tabdat-test-patts vec)))(if val val ""))) ;;RADT => What is the if for? ;; additional setters for dboard:data (define (dboard:tabdat-test-patts-set!-use vec val) (dboard:tabdat-test-patts-set! vec (if (equal? val "") #f val))) @@ -264,21 +386,29 @@ (dboard:setup-tabdat dat) (dboard:setup-num-rows dat) dat)) (define (dboard:setup-tabdat tabdat) - (dboard:tabdat-dbdir-set! tabdat (db:dbfile-path #f)) ;; (conc (configf:lookup *configdat* "setup" "linktree") "/.db")) - (dboard:tabdat-dbfpath-set! tabdat (db:dbfile-path 0)) + (dboard:tabdat-dbdir-set! tabdat (db:dbfile-path)) ;; (conc (configf:lookup *configdat* "setup" "linktree") "/.db")) + (dboard:tabdat-dbfpath-set! tabdat (db:dbfile-path)) (dboard:tabdat-monitor-db-path-set! tabdat (conc (dboard:tabdat-dbdir tabdat) "/monitor.db")) ;; HACK ALERT: this is a hack, please fix. (dboard:tabdat-ro-set! tabdat (not (file-read-access? (dboard:tabdat-dbfpath tabdat)))) (dboard:tabdat-keys-set! tabdat (rmt:get-keys)) (dboard:tabdat-dbkeys-set! tabdat (append (dboard:tabdat-keys tabdat) (list "runname"))) (dboard:tabdat-tot-runs-set! tabdat (rmt:get-num-runs "%")) ) + +;; RADT => Matrix defstruct addition +(defstruct dboard:graph-dat + ((id #f) : string) + ((color #f) : vector) + ((flag #t) : boolean) + ((cell #f) : number) + ) ;; data for runs, tests etc. was used in run summary? ;; (defstruct dboard:runsdat ;; new system @@ -303,68 +433,114 @@ rowsused ;; hash of lists covering what areas used - replace with quadtree hierdat ;; put hierarchial sorted list here tests ;; hash of id => testdat ((tests-by-name (make-hash-table)) : hash-table) ;; hash of testfullname => testdat key-vals - ((last-update 0) : fixnum) ;; last query to db got records from before last-update - ((data-changed #f) : boolean) - ((run-data-offset 0) : number) ;; get only 100 items per call, set back to zero when received less that 100 items - (db-path #f) + ((last-update 0) : number) ;; last query to db got records from before last-update + ((last-db-time 0) : number) ;; last timestamp on megatest.db + ((data-changed #f) : boolean) + ((run-data-offset 0) : number) ;; get only 100 items per call, set back to zero when received less than 100 items + (db-path #f)) + +;; for the new runs view lets build up a few new record types and then consolidate later +;; +;; this is a two level deep pipeline for the incoming data: +;; sql query data ==> filters ==> data for display +;; +(defstruct dboard:rdat + ;; view related items + (runnum 0) ;; which column we are processing, index into runsbynum, we sweep across all these runs then start over + (leftcol 0) ;; number of the leftmost visible column + (toprow 0) ;; topmost visible row + (numcols 24) ;; number of columns visible + (numrows 20) ;; number of rows visible + + ;; data from sql db + (keys (rmt:get-keys)) ;; to be removed when targets handling is refactored + (runs (make-sparse-vector)) ;; id => runrec + (runsbynum (make-vector 100 #f)) ;; vector num => runrec + (targ-runid (make-hash-table)) ;; area/target/runname => run-id ;; not sure this will be needed + (tests (make-hash-table)) ;; test[/itempath] => list of test rec + + ;; run sql filters + (targ-sql-filt "%") + (runname-sql-filt "%") + (run-state-sql-filt "%") + (run-status-sql-filt "%") + + ;; test sql filter + (testname-sql-filt "%") + (itempath-sql-filt "%") + (test-state-sql-filt "%") + (test-status-sql-filt "%") + + ;; other sql related fields + (last-updates (make-sparse-vector 0)) ;; run-id -> timestamp of the last update from sql db, set to zero on any field changes + + ;; filtered data + (cols (make-sparse-vector)) ;; columnnum => run-id + (tests (make-hash-table)) ;; test[/itempath] => (vector columnnum => test rec) + + ;; various + (prev-run-ids '()) ;; push previously looked at runs on this + (view-changed #f) + + ;; widgets + (runs-tree #f) ;; + ) + +(define (dboard:rdat-push-run-id rdat run-id) + (dboard:rdat-prev-run-ids-set! rdat (cons run-id (dboard:rdat-prev-run-ids rdat)))) + +(defstruct dboard:runrec + id + target ;; a/b/c... + tdef ;; for future use + ) + +(defstruct dboard:testrec + id + runid + testname ;; test[/itempath] + state + status + start-time + duration ) + +;; register dboard:rundat with BBpp +;; this is used by BBpp (Brandon's pretty printer) to convert dboard:rundat into a composition of lists that pp will handle +(hash-table-set! *BBpp_custom_expanders_list* RUNDAT: + (cons dboard:rundat? + (lambda (tabdat-item) + (filter + (lambda (alist-entry) + (member (car alist-entry) + '(run run-data-offset ))) ;; FIELDS OF INTEREST + (dboard:rundat->alist tabdat-item))))) + + + (define (dboard:rundat-make-init #!key (run #f)(key-vals #f)(tests #f));; -100 is before time began (make-dboard:rundat run: run tests: (or tests (make-hash-table)) key-vals: key-vals )) -(define (dboard:rundat-copy-tests-to-by-name rundat) - (let ((src-ht (dboard:rundat-tests rundat)) - (trg-ht (dboard:rundat-tests-by-name rundat))) - (if (and (hash-table? src-ht)(hash-table? trg-ht)) - (begin - (hash-table-clear! trg-ht) - (for-each - (lambda (testdat) - (hash-table-set! trg-ht (test:test-get-fullname testdat) testdat)) - (hash-table-values src-ht))) - (debug:print 0 *default-log-port* "WARNING: src-ht " src-ht " trg-ht " trg-ht)))) - (defstruct dboard:testdat id ;; testid state ;; test state status ;; test status ) -(define (dboard:runsdat-get-col-num dat target runname force-set) - (let* ((runs-index (dboard:runsdat-runs-index dat)) - (col-name (conc target "/" runname)) - (res (hash-table-ref/default runs-index col-name #f))) - (if res - res - (if force-set - (let ((max-col-num (+ 1 (apply max -1 (hash-table-values runs-index))))) - (hash-table-set! runs-index col-name max-col-num) - max-col-num))))) - -(define (dboard:runsdat-get-row-num dat testname itempath force-set) - (let* ((tests-index (dboard:runsdat-runs-index dat)) - (row-name (conc testname "/" itempath)) - (res (hash-table-ref/default runs-index row-name #f))) - (if res - res - (if force-set - (let ((max-row-num (+ 1 (apply max -1 (hash-table-values tests-index))))) - (hash-table-set! runs-index row-name max-row-num) - max-row-num))))) - ;; default is to NOT set the cell if the column and row names are not pre-existing ;; (define (dboard:runsdat-set-test-cell dat target runname testname itempath test-id state status #!key (force-set #f)) - (let* ((col-num (dboard:runsdat-get-col-num dat target runname force-set)) - (row-num (dboard:runsdat-get-row-num dat testname itempath force-set))) + (let* ((col-num (dcommon:runsdat-get-col-num dat target runname force-set)) + (row-num (dcommon:runsdat-get-row-num dat testname itempath force-set))) (if (and row-num col-num) (let ((tdat (dboard:testdat id: test-id state: state status: status))) @@ -472,62 +648,87 @@ ;; gets all the tests for run-id that match testnamepatt and key-vals, merges them ;; ;; NOTE: Yes, this is used ;; (define (dboard:get-tests-for-run-duplicate tabdat run-id run testnamepatt key-vals) - (let* ((num-to-get 100) - (states (hash-table-keys (dboard:tabdat-state-ignore-hash tabdat))) - (statuses (hash-table-keys (dboard:tabdat-status-ignore-hash tabdat))) - (sort-info (get-curr-sort)) - (sort-by (vector-ref sort-info 1)) - (sort-order (vector-ref sort-info 2)) - (bubble-type (if (member sort-order '(testname)) - 'testname - 'itempath)) + (let* ((start-time (current-seconds)) + (access-mode (dboard:tabdat-access-mode tabdat)) + (num-to-get (string->number (or (configf:lookup *configdat* "setup" "num-tests-to-get") + "200"))) + (states (hash-table-keys (dboard:tabdat-state-ignore-hash tabdat))) + (statuses (hash-table-keys (dboard:tabdat-status-ignore-hash tabdat))) + (do-not-use-db-file-timestamps #t) ;; (configf:lookup *configdat* "setup" "do-not-use-db-file-timestamps")) ;; this still hosts runs-summary-tab + (do-not-use-query-timestamps #t) ;; (configf:lookup *configdat* "setup" "do-not-use-query-timestamps")) ;; this no longer troubles runs-summary-tab + (sort-info (get-curr-sort)) + (sort-by (vector-ref sort-info 1)) + (sort-order (vector-ref sort-info 2)) + (bubble-type (if (member sort-order '(testname)) + 'testname + 'itempath)) ;; note: the rundat is normally created in "update-rundat". - (run-dat (or (hash-table-ref/default (dboard:tabdat-allruns-by-id tabdat) run-id #f) - (let ((rd (dboard:rundat-make-init run: run key-vals: key-vals))) - (hash-table-set! (dboard:tabdat-allruns-by-id tabdat) run-id rd) - rd))) + (run-dat (or (hash-table-ref/default (dboard:tabdat-allruns-by-id tabdat) run-id #f) + (let ((rd (dboard:rundat-make-init run: run key-vals: key-vals))) + (hash-table-set! (dboard:tabdat-allruns-by-id tabdat) run-id rd) + rd))) ;; (prev-tests (dboard:rundat-tests prev-dat)) ;; (vector-ref prev-dat 1)) - (last-update (dboard:rundat-last-update run-dat)) ;; (vector-ref prev-dat 3)) - (db-path (or (dboard:rundat-db-path run-dat) - (let* ((db-dir (tasks:get-task-db-path)) - (db-pth (conc db-dir "/" run-id ".db"))) - (dboard:rundat-db-path-set! run-dat db-pth) - db-pth))) - (tmptests (if (or (configf:lookup *configdat* "setup" "do-not-use-db-file-timestamps") - (>= (file-modification-time db-path) last-update)) - (rmt:get-tests-for-run run-id testnamepatt states statuses ;; run-id testpatt states statuses - (dboard:rundat-run-data-offset run-dat) - num-to-get - (dboard:tabdat-hide-not-hide tabdat) ;; no-in - sort-by ;; sort-by - sort-order ;; sort-order - #f ;; 'shortlist ;; qrytype - (if (dboard:tabdat-filters-changed tabdat) - 0 - last-update) ;; last-update - *dashboard-mode*) ;; use dashboard mode - '())) + (last-update (if ;;(or + do-not-use-query-timestamps + ;;(dboard:tabdat-filters-changed tabdat)) + 0 + (dboard:rundat-last-update run-dat))) + (last-db-time (if do-not-use-db-file-timestamps + 0 + (dboard:rundat-last-db-time run-dat))) + (db-path (or (dboard:rundat-db-path run-dat) + (let* ((db-dir (common:get-db-tmp-area)) + (db-pth (conc db-dir "/megatest.db"))) + (dboard:rundat-db-path-set! run-dat db-pth) + db-pth))) + (db-mod-time (common:lazy-sqlite-db-modification-time db-path)) + (db-modified (>= db-mod-time last-db-time)) + (multi-get (> (dboard:rundat-run-data-offset run-dat) 0)) ;; multi-get in progress + (tmptests (if (or do-not-use-db-file-timestamps + (dboard:tabdat-filters-changed tabdat) + db-modified) + (rmt:get-tests-for-run run-id testnamepatt states statuses ;; run-id testpatt states statuses + (dboard:rundat-run-data-offset run-dat) ;; query offset + num-to-get + (dboard:tabdat-hide-not-hide tabdat) ;; no-in + sort-by ;; sort-by + sort-order ;; sort-order + #f ;; 'shortlist ;; qrytype + last-update ;; last-update + *dashboard-mode*) ;; use dashboard mode + '())) (use-new (dboard:tabdat-hide-not-hide tabdat)) (tests-ht (if (dboard:tabdat-filters-changed tabdat) (let ((ht (make-hash-table))) (dboard:rundat-tests-set! run-dat ht) ht) (dboard:rundat-tests run-dat))) - (start-time (current-seconds))) + (got-all (< (length tmptests) num-to-get)) ;; got all for this round + ) + + ;; if we saw the db modified, reset it (the signal has already been used) + (if (and got-all ;; (not multi-get) + db-modified) + (dboard:rundat-last-db-time-set! run-dat (- start-time 2))) ;; to limit the amount of data transferred each cycle use limit of num-to-get and offset - (dboard:rundat-run-data-offset-set! - run-dat - (if (< (length tmptests) num-to-get) - 0 - (let ((newval (+ num-to-get (dboard:rundat-run-data-offset run-dat)))) - ;; (print "Incremental get, offset=" (dboard:rundat-run-data-offset run-dat) " retrieved: " (length tmptests) " newval: " newval) - newval))) - + ;; DO NOT bump time indexes last-update and last-db-time until all the first pass of the + ;; data has been read + ;; set last-update to 0 if still getting data incrementally ;; NO NEED, handled above + ;; + ;; (debug:print 0 *default-log-port* "got-all: " got-all " multi-get: " multi-get " num-to-get: " num-to-get " (length tmptests): " (length tmptests) " db-modified: " db-modified " db-mod-time: " db-mod-time " db-path: " db-path) + (if got-all + (begin + (dboard:rundat-last-update-set! run-dat (- start-time 2)) + (dboard:rundat-run-data-offset-set! run-dat 0)) + (begin + (dboard:rundat-run-data-offset-set! run-dat + (+ num-to-get (dboard:rundat-run-data-offset run-dat))))) + (for-each (lambda (tdat) (let ((test-id (db:test-get-id tdat)) (state (db:test-get-state tdat))) (dboard:rundat-data-changed-set! run-dat #t) @@ -534,19 +735,10 @@ (if (equal? state "DELETED") (hash-table-delete! tests-ht test-id) (hash-table-set! tests-ht test-id tdat)))) tmptests) - ;; set last-update to 0 if still getting data incrementally - - (if (> (dboard:rundat-run-data-offset run-dat) 0) - (begin - ;; (print "run-data-offset: " (dboard:rundat-run-data-offset run-dat) ", setting last-update to 0") - (dboard:rundat-last-update-set! run-dat 0)) - (dboard:rundat-last-update-set! run-dat (- (current-seconds) 2))) ;; go back two seconds in time to ensure all changes are captured. - - ;; (debug:print-info 0 *default-log-port* "tests-ht: " (hash-table-keys tests-ht)) tests-ht)) ;; tmptests - new tests data ;; prev-tests - old tests data ;; @@ -568,15 +760,16 @@ ;; ;; create a virtual table of all the tests ;; keypatts: ( (KEY1 "abc%def")(KEY2 "%") ) ;; (define (update-rundat tabdat runnamepatt numruns testnamepatt keypatts) - (let* ((keys (rmt:get-keys)) - (last-runs-update (dboard:tabdat-last-runs-update tabdat)) + (let* ((access-mode (dboard:tabdat-access-mode tabdat)) + (keys (rmt:get-keys)) + (last-runs-update (- (dboard:tabdat-last-runs-update tabdat) 2)) (allruns (rmt:get-runs runnamepatt numruns (dboard:tabdat-start-run-offset tabdat) keypatts)) ;;(allruns-tree (rmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f)) - (allruns-tree (rmt:get-runs-by-patt keys "%" #f #f #f #f last-runs-update));;'("id" "runname") + (allruns-tree (rmt:get-runs-by-patt keys "%" #f #f #f #f last-runs-update)) ;;'("id" "runname") (header (db:get-header allruns)) (runs (db:get-rows allruns)) ;; RA => Filtered as per runpatt selected (runs-tree (db:get-rows allruns-tree)) ;; RA => Returns complete list of runs (start-time (current-seconds)) (runs-hash (let ((ht (make-hash-table))) @@ -583,10 +776,12 @@ (for-each (lambda (run) (hash-table-set! ht (db:get-value-by-header run header "id") run)) runs-tree) ;; (vector-ref runs-dat 1)) ht)) (tb (dboard:tabdat-runs-tree tabdat))) + ;;(BB> "In update-rundat") + ;;(inspect allruns runs-hash) (dboard:tabdat-last-runs-update-set! tabdat (- (current-seconds) 2)) (dboard:tabdat-header-set! tabdat header) ;; ;; trim runs to only those that are changing often here ;; @@ -638,10 +833,102 @@ (loop run tal new-res newmaxtests) ;; not done getting data for this run (loop (car tal)(cdr tal) new-res newmaxtests))))))) (dboard:tabdat-filters-changed-set! tabdat #f) (dboard:update-tree tabdat runs-hash header tb))) +;; this calls dboard:get-tests-for-run-duplicate for each run +;; +;; create a virtual table of all the tests +;; keypatts: ( (KEY1 "abc%def")(KEY2 "%") ) +;; +(define (dboard:update-rundat tabdat runnamepatt numruns testnamepatt keypatts) + (let* ((access-mode (dboard:tabdat-access-mode tabdat)) + (keys (dboard:tabdat-keys tabdat)) ;; (db:dispatch-query access-mode rmt:get-keys db:get-keys))) + (last-runs-update (- (dboard:tabdat-last-runs-update tabdat) 2)) + (allruns (rmt:get-runs runnamepatt numruns (dboard:tabdat-start-run-offset tabdat) keypatts)) + ;;(allruns-tree (rmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f)) + (allruns-tree (rmt:get-runs-by-patt keys "%" #f #f #f #f 0)) ;; last-runs-update));;'("id" "runname") + (header (db:get-header allruns)) + (runs (db:get-rows allruns)) ;; RA => Filtered as per runpatt selected + (runs-tree (db:get-rows allruns-tree)) ;; RA => Returns complete list of runs + (start-time (current-seconds)) + (runs-hash (let ((ht (make-hash-table))) + (for-each (lambda (run) + (hash-table-set! ht (db:get-value-by-header run header "id") run)) + runs-tree) ;; (vector-ref runs-dat 1)) + ht)) + (tb (dboard:tabdat-runs-tree tabdat))) + (dboard:tabdat-last-runs-update-set! tabdat (- (current-seconds) 2)) + (dboard:tabdat-header-set! tabdat header) + ;; + ;; trim runs to only those that are changing often here + ;; + (if (null? runs) + (begin + (dboard:tabdat-allruns-set! tabdat '()) + (dboard:tabdat-all-test-names-set! tabdat '()) + (dboard:tabdat-item-test-names-set! tabdat '()) + (hash-table-clear! (dboard:tabdat-allruns-by-id tabdat))) + (let loop ((run (car runs)) + (tal (cdr runs)) + (res '()) + (maxtests 0)) + (let* ((run-id (db:get-value-by-header run header "id")) + (run-struct (hash-table-ref/default (dboard:tabdat-allruns-by-id tabdat) run-id #f)) + ;; (last-update (if run-struct (dboard:rundat-last-update run-struct) 0)) + (key-vals (rmt:get-key-vals run-id)) + (tests-ht (dboard:get-tests-for-run-duplicate tabdat run-id run testnamepatt key-vals)) + ;; GET RID OF dboard:get-tests-dat - it is superceded by dboard:get-tests-for-run-duplicate + ;; dboard:get-tests-for-run-duplicate - returns a hash table + ;; (dboard:get-tests-dat tabdat run-id last-update)) + (all-test-ids (hash-table-keys tests-ht)) + (num-tests (length all-test-ids))) + ;; (print "run-struct: " run-struct) + ;; NOTE: bubble-up also sets the global (dboard:tabdat-item-test-names tabdat) + ;; (tests (bubble-up tmptests priority: bubble-type)) + ;; NOTE: 11/01/2013 This routine is *NOT* getting called excessively. + ;; (debug:print 0 *default-log-port* "Getting data for run " run-id " with key-vals=" key-vals) + ;; Not sure this is needed? + (let* ((newmaxtests (max num-tests maxtests)) + ;; (last-update (- (current-seconds) 10)) + (run-struct (or run-struct + (dboard:rundat-make-init + run: run + tests: tests-ht + key-vals: key-vals))) + (new-res (if (null? all-test-ids) + res + (delete-duplicates + (cons run-struct res) + (lambda (a b) + (eq? (db:get-value-by-header (dboard:rundat-run a) header "id") + (db:get-value-by-header (dboard:rundat-run b) header "id")))))) + (elapsed-time (- (current-seconds) start-time))) + (if (null? all-test-ids) + (hash-table-delete! (dboard:tabdat-allruns-by-id tabdat) run-id) + (hash-table-set! (dboard:tabdat-allruns-by-id tabdat) run-id run-struct)) + (if (or (null? tal) + (> elapsed-time 2)) ;; stop loading data after 5 seconds, on the next call more data *should* be loaded since get-tests-for-run uses last update + (begin + (when (> elapsed-time 2) + (debug:print 0 *default-log-port* "NOTE: updates are taking a long time, " elapsed-time "s elapsed.") + (let* ((old-val (iup:attribute *tim* "TIME")) + (new-val (number->string (inexact->exact (floor (* 2 (string->number old-val))))))) + (if (< (string->number new-val) 5000) + ((debug:print 0 *default-log-port* "NOTE: increasing poll interval from "old-val" to "new-val) + (iup:attribute-set! *tim* "TIME" new-val)))) + + + ) + (dboard:tabdat-allruns-set! tabdat new-res) + maxtests) + (if (> (dboard:rundat-run-data-offset run-struct) 0) + (loop run tal new-res newmaxtests) ;; not done getting data for this run + (loop (car tal)(cdr tal) new-res newmaxtests))))))) + (dboard:tabdat-filters-changed-set! tabdat #f) + (dboard:update-tree tabdat runs-hash header tb))) + (define *collapsed* (make-hash-table)) (define (toggle-hide lnum uidat) ; fulltestname) (let* ((btn (vector-ref (dboard:uidat-get-lftcol uidat) lnum)) (fulltestname (iup:attribute btn "TITLE")) @@ -648,11 +935,11 @@ (parts (string-split fulltestname "(")) (basetestname (if (null? parts) "" (car parts)))) ;(print "Toggling " basetestname " currently " (hash-table-ref/default *collapsed* basetestname #f)) (if (hash-table-ref/default *collapsed* basetestname #f) (begin - ;(iup:attribute-set! btn "FGCOLOR" "0 0 0") + ;(iup:attribute-set! btn "FGCOLOR" "0 0 0")s (hash-table-delete! *collapsed* basetestname)) (begin ;(iup:attribute-set! btn "FGCOLOR" "0 192 192") (hash-table-set! *collapsed* basetestname #t))))) @@ -790,19 +1077,18 @@ (lftcol (dboard:uidat-get-lftcol uidat)) (tableheader (dboard:uidat-get-header uidat)) (table (dboard:uidat-get-runsvec uidat)) (coln 0) (all-test-names (make-hash-table))) - ;; create a concise list of test names ;; (for-each (lambda (rundat) (if rundat (let* ((testdats (dboard:rundat-tests rundat)) (testnames (map test:test-get-fullname (hash-table-values testdats)))) - (dboard:rundat-copy-tests-to-by-name rundat) + (dcommon:rundat-copy-tests-to-by-name rundat) ;; for the normalized list of testnames (union of all runs) (if (not (and (dboard:tabdat-hide-empty-runs tabdat) (null? testnames))) (for-each (lambda (testname) (hash-table-set! all-test-names testname #t)) @@ -839,11 +1125,11 @@ (testsdat-by-name (dboard:rundat-tests-by-name rundat)) (key-val-dat (dboard:rundat-key-vals rundat)) (run-id (db:get-value-by-header run (dboard:tabdat-header tabdat) "id")) (key-vals (append key-val-dat (list (let ((x (db:get-value-by-header run (dboard:tabdat-header tabdat) "runname"))) - (if x x ""))))) + (if (string? x) x ""))))) (run-key (string-intersperse key-vals "\n"))) ;; fill in the run header key values ;; (let ((rown 0) @@ -889,13 +1175,14 @@ (button (vector-ref columndat rown)) (color (car (gutils:get-color-for-state-status teststate teststatus))) (curr-color (vector-ref buttondat 1)) ;; (iup:attribute button "BGCOLOR")) (curr-title (vector-ref buttondat 2))) ;; (iup:attribute button "TITLE"))) (if (not (equal? curr-color color)) - (iup:attribute-set! button "BGCOLOR" color)) + #;(iup:attribute-set! button "BGCOLOR" color) + (iup:attribute-set! button "FGCOLOR" color)) (if (not (equal? curr-title buttontxt)) - (iup:attribute-set! button "TITLE" buttontxt)) + (iup:attribute-set! button "TITLE" (conc "" buttontxt ""))) (vector-set! buttondat 0 run-id) (vector-set! buttondat 1 color) (vector-set! buttondat 2 buttontxt) (vector-set! buttondat 3 testdat) (vector-set! buttondat 4 run-key))) @@ -923,15 +1210,17 @@ (dboard:tabdat-filters-changed-set! tabdat #t))) (define (update-search commondat tabdat x val) (hash-table-set! (dboard:tabdat-searchpatts tabdat) x val) (dboard:tabdat-filters-changed-set! tabdat #t) + (mark-for-update tabdat) (set-bg-on-filter commondat tabdat)) +;; force ALL updates to zero (effectively) +;; (define (mark-for-update tabdat) - ;; (dboard:tabdat-filters-changed-set! tabdat #t) - (dboard:tabdat-last-db-update-set! tabdat 0)) + (dboard:tabdat-last-db-update-set! tabdat (make-hash-table))) ;;====================================================================== ;; R U N C O N T R O L ;;====================================================================== @@ -1062,11 +1351,14 @@ ;; (define (dashboard:update-run-command tabdat) (let* ((cmd-tb (dboard:tabdat-command-tb tabdat)) (cmd (dboard:tabdat-command tabdat)) (test-patt (let ((tp (dboard:tabdat-test-patts tabdat))) - (if (equal? tp "") "%" tp))) + (if (or (not tp) + (equal? tp "")) + "%" + tp))) (states (dboard:tabdat-states tabdat)) (statuses (dboard:tabdat-statuses tabdat)) (target (let ((targ-list (dboard:tabdat-target tabdat))) (if targ-list (string-intersperse targ-list "/") "no-target-selected"))) (run-name (dboard:tabdat-run-name tabdat)) @@ -1149,10 +1441,11 @@ ;; (define (dashboard:update-tree-selector tabdat #!key (action-proc #f)) (let* ((tb (dboard:tabdat-runs-tree tabdat)) (runconf-targs (common:get-runconfig-targets)) (db-target-dat (rmt:get-targets)) + (runs-tree-ht (dboard:tabdat-runs-tree-ht tabdat)) (header (vector-ref db-target-dat 0)) (db-targets (vector-ref db-target-dat 1)) (munge-target (lambda (x) ;; create a target vector from a string. Pad with na if needed. (take (append (string-split x "/") (make-list (length header) "na")) @@ -1164,13 +1457,20 @@ (map munge-target runconf-targs) ))) (for-each (lambda (target) - (tree:add-node tb "Runs" target)) ;; (append key-vals (list run-name)) + (if (not (hash-table-ref/default runs-tree-ht target #f)) + ;; (let ((existing (tree:find-node tb target))) + ;; (if (not existing) + (begin + (tree:add-node tb "Runs" target) ;; (append key-vals (list run-name)) + (hash-table-set! runs-tree-ht target #t)))) all-targets))) +;; Run controls panel +;; (define (dashboard:run-controls commondat tabdat #!key (tab-num #f)) (let* ((targets (make-hash-table)) (test-records (make-hash-table)) (all-tests-registry (tests:get-all)) ;; (tests:get-valid-tests *toppath* '())) (test-names (hash-table-keys all-tests-registry)) @@ -1199,23 +1499,27 @@ ;; (iup:split ;; #:value 300 ;; Target, testpatt, state and status input boxes ;; - (iup:vbox - ;; Command to run, placed over the top of the canvas - (dcommon:command-action-selector commondat tabdat tab-num: tab-num) - (dboard:runs-tree-browser commondat tabdat) - (dcommon:command-runname-selector commondat tabdat tab-num: tab-num) - (dcommon:command-testname-selector commondat tabdat update-keyvals)) + (iup:split + #:orientation "HORIZONTAL" + (iup:vbox + ;; Command to run, placed over the top of the canvas + (dcommon:command-action-selector commondat tabdat tab-num: tab-num) + (dboard:runs-tree-browser commondat tabdat)) + (iup:vbox + (dcommon:command-runname-selector commondat tabdat tab-num: tab-num) + (dcommon:command-testname-selector commondat tabdat update-keyvals))) ;; key-listboxes)) (dcommon:command-tests-tasks-canvas tabdat test-records sorted-testnames tests-draw-state)))) (tb (dboard:tabdat-runs-tree tabdat))) (dboard:commondat-add-updater commondat (lambda () - (dashboard:update-tree-selector tabdat)) + (if (dashboard:database-changed? commondat tabdat context-key: 'run-control) + (dashboard:update-tree-selector tabdat))) tab-num: tab-num) result))) ;;(iup:frame ;; #:title "Logs" ;; To be replaced with tabs @@ -1222,35 +1526,150 @@ ;; (let ((logs-tb (iup:textbox #:expand "YES" ;; #:multiline "YES"))) ;; (dboard:tabdat-logs-textbox-set! tabdat logs-tb) ;; logs-tb)) +(define (dboard:runs-tree-txtbox-change tabdat val a b) + (if b (dboard:tabdat-target-set! tabdat (string-split b "/"))) + (dashboard:update-run-command tabdat)) + +;; browse runs as a tree. Used in both "Runs" tab and +;; in the runs control panel. +;; (define (dboard:runs-tree-browser commondat tabdat) - (let* ((tb (iup:treebox - #:value 0 - #:name "Runs" - #:expand "YES" - #:addexpanded "NO" - #:selection-cb - (lambda (obj id state) - (debug:catch-and-dump - (lambda () - (let* ((run-path (tree:node->path obj id)) - (run-id (tree-path->run-id tabdat (cdr run-path)))) - ;; (dboard:tabdat-view-changed-set! tabdat #t) ;; ?? done below when run-id is a number - (dboard:tabdat-target-set! tabdat (cdr run-path)) ;; (print "run-path: " run-path) - (dboard:tabdat-layout-update-ok-set! tabdat #f) - (if (number? run-id) - (begin - (dboard:tabdat-curr-run-id-set! tabdat run-id) - (dboard:tabdat-view-changed-set! tabdat #t)) - (debug:print-error 5 *default-log-port* "tree-path->run-id returned non-number " run-id)))) - "treebox")) - ;; (print "path: " (tree:node->path obj id) " run-id: " run-id) - ))) + (let* ((txtbox (iup:textbox + #:action (lambda (val a b) + (debug:catch-and-dump + (lambda () + (dboard:runs-tree-txtbox-change tabdat val a b)) + "command-testname-selector tb action")) + #:value (dboard:test-patt->lines + (dboard:tabdat-test-patts-use tabdat)) + #:expand "HORIZONTAL" + ;; #:size "10x30" + )) + (tb + (iup:treebox + #:value 0 + #:title "Runs" ;; was #:name -- iup 3.19 changed + ;; this... "Changed: [DEPRECATED + ;; REMOVED] removed the old attribute + ;; NAMEid from IupTree to avoid + ;; conflict with the common attribute + ;; NAME. Use the TITLEid attribute." + #:expand "YES" + #:addexpanded "YES" + #:size "10x" + #:selection-cb + (lambda (obj id state) + (debug:catch-and-dump + (lambda () + (let* ((run-path (tree:node->path obj id)) + (run-id (tree-path->run-id tabdat (cdr run-path)))) + ;; (dboard:tabdat-view-changed-set! tabdat #t) ;; ?? + ;; done below when run-id is a number + (dboard:tabdat-target-set! tabdat (cdr run-path)) ;; (print + ;; "run-path: + ;; " + ;; run-path) + (iup:attribute-set! txtbox "VALUE" + (string-intersperse (cdr run-path) "/")) + (dashboard:update-run-command tabdat) + (dboard:tabdat-layout-update-ok-set! tabdat #f) + (if (number? run-id) + (begin + ;; capture last two in tabdat. + (dboard:tabdat-prev-run-id-set! + tabdat + (dboard:tabdat-curr-run-id tabdat)) + (dboard:tabdat-curr-run-id-set! tabdat run-id) + (dboard:tabdat-view-changed-set! tabdat #t)) + (debug:print-error 5 *default-log-port* "tree-path->run-id returned non-number " run-id)))) + "treebox")) + ;; (print "path: " (tree:node->path obj id) " run-id: " run-id) + ))) (dboard:tabdat-runs-tree-set! tabdat tb) - tb)) + (if (args:get-arg "-runname") + (let ((runname (args:get-arg "-runname"))) + (update-search commondat tabdat "runname" runname) + #;(hash-table-set! (dboard:tabdat-searchpatts tabdat) "runname" runname))) + (if (args:get-arg "-target") ;; + (let ((target (args:get-arg "-target"))) + (iup:attribute-set! txtbox value: target) + (dboard:runs-tree-txtbox-change tabdat #f #f target))) + (iup:detachbox + (iup:vbox + txtbox + tb + )))) + +;; browse runs as a tree. Used in both "Runs" tab and +;; in the runs control panel. +;; +;; THIS IS THE NEW ONE +;; +(define (dboard:runs-tree-new-browser commondat rdat) + (let* ((txtbox (iup:textbox + #:action (lambda (val a b) + (debug:catch-and-dump + (lambda () + ;; for the Runs view we put the list + ;; of keyvals into tabdat target for + ;; the Run Controls we put then update + ;; the run-command + (if b (dboard:rdat-targ-sql-filt-set! rdat + (string-split b "/"))) + #;(dashboard:update-run-command tabdat)) + "command-testname-selector tb action")) + ;; #:value (dboard:test-patt->lines ;; This seems like it was wrong, BUG in code where it was copied from? + ;; (dboard:tabdat-test-patts-use tabdat)) + #:expand "HORIZONTAL" + ;; #:size "10x30" + )) + (tb + (iup:treebox + #:value 0 + #:title "Runs" ;; was #:name -- iup 3.19 changed + ;; this... "Changed: [DEPRECATED + ;; REMOVED] removed the old attribute + ;; NAMEid from IupTree to avoid + ;; conflict with the common attribute + ;; NAME. Use the TITLEid attribute." + #:expand "YES" + #:addexpanded "YES" + #:size "10x" + #:selection-cb + (lambda (obj id state) + (debug:catch-and-dump + (lambda () + (let* ((run-path (tree:node->path obj id)) + (run-id (new-tree-path->run-id rdat (cdr run-path)))) + ;; (dboard:tabdat-view-changed-set! tabdat #t) ;; ?? + ;; done below when run-id is a number + (dboard:rdat-targ-sql-filt-set! rdat (cdr run-path)) ;; (print + ;; "run-path: + ;; " + ;; run-path) + (iup:attribute-set! txtbox "VALUE" + (string-intersperse (cdr run-path) "/")) + #;(dashboard:update-run-command tabdat) + #;(dboard:tabdat-layout-update-ok-set! tabdat #f) + (if (number? run-id) + (begin + ;; capture last two in tabdat. + (dboard:rdat-push-run-id rdat run-id) + (dboard:rdat-view-changed-set! rdat #t)) + (debug:print-error 5 *default-log-port* "tree-path->run-id returned non-number " run-id)))) + "treebox")) + ;; (print "path: " (tree:node->path obj id) " run-id: " run-id) + ))) + (dboard:rdat-runs-tree-set! rdat tb) + (iup:detachbox + (iup:vbox + txtbox + tb + )))) ;;====================================================================== ;; R U N C O N T R O L S ;;====================================================================== ;; @@ -1311,12 +1730,15 @@ ) "text-list-toggle-box")))) (dcommon:command-runname-selector commondat tabdat tab-num: tab-num) (dcommon:command-testname-selector commondat tabdat update-keyvals)) (iup:vbox + (iup:split + #:orientation "HORIZONTAL" + #:value 800 (let* ((cnv-obj (iup:canvas - ;; #:size "500x400" + ;; #:size "250x250" ;; "500x400" #:expand "YES" #:scrollbar "YES" #:posx "0.5" #:posy "0.5" #:action (make-canvas-action @@ -1351,11 +1773,61 @@ (if (> step 0) (* scalex 0.02) (* scalex -0.02)))))) "wheel-cb")) ))) - cnv-obj))))) + cnv-obj) + (let* ((hb1 (iup:hbox)) + (graph-cell-table (dboard:tabdat-graph-cell-table tabdat)) + (changed #f) + (graph-matrix (iup:matrix + #:alignment1 "ALEFT" + ;; #:expand "YES" ;; "HORIZONTAL" + #:scrollbar "YES" + #:numcol 10 + #:numlin 20 + #:numcol-visible 5 ;; (min 8) + #:numlin-visible 1 + #:click-cb + (lambda (obj row col status) + (let* + ((graph-cell (conc row ":" col)) + (graph-dat (hash-table-ref/default graph-cell-table graph-cell #f)) + (graph-flag (dboard:graph-dat-flag graph-dat))) + (if graph-flag + (dboard:graph-dat-flag-set! graph-dat #f) + (dboard:graph-dat-flag-set! graph-dat #t)) + (if (not (dboard:tabdat-running-layout tabdat)) + (begin + (dashboard:run-times-tab-run-data-updater commondat tabdat tab-num) + (dboard:tabdat-last-data-update-set! tabdat (current-seconds)) + (thread-start! (make-thread + (lambda () + (dboard:tabdat-running-layout-set! tabdat #t) + (dashboard:run-times-tab-layout-updater commondat tabdat tab-num) + (dboard:tabdat-running-layout-set! tabdat #f)) + "run-times-tab-layout-updater")))) + ;;(dboard:tabdat-view-changed-set! tabdat #t) + ))))) + (dboard:tabdat-graph-matrix-set! tabdat graph-matrix) + (iup:attribute-set! graph-matrix "WIDTH0" 0) + (iup:attribute-set! graph-matrix "HEIGHT0" 0) + graph-matrix)) + (iup:hbox + (iup:vbox + (iup:button "Show All" #:action (lambda (obj) + (for-each (lambda (graph-cell) + (let* ((graph-dat (hash-table-ref (dboard:tabdat-graph-cell-table tabdat) graph-cell))) + (dboard:graph-dat-flag-set! graph-dat #t))) + (hash-table-keys (dboard:tabdat-graph-cell-table tabdat)))))) + (iup:hbox + (iup:button "Hide All" #:action (lambda (obj) + (for-each (lambda (graph-cell) + (let* ((graph-dat (hash-table-ref (dboard:tabdat-graph-cell-table tabdat) graph-cell))) + (dboard:graph-dat-flag-set! graph-dat #f))) + (hash-table-keys (dboard:tabdat-graph-cell-table tabdat))))))) + )))) ;;====================================================================== ;; R U N ;;====================================================================== ;; @@ -1364,43 +1836,51 @@ (define (tree-path->run-id tabdat path) (if (not (null? path)) (hash-table-ref/default (dboard:tabdat-path-run-ids tabdat) path #f) #f)) -(define (dboard:get-tests-dat tabdat run-id last-update) - (let* ((tdat (if run-id (rmt:get-tests-for-run run-id - (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "test-name" "%/%") - (hash-table-keys (dboard:tabdat-state-ignore-hash tabdat)) ;; '() - (hash-table-keys (dboard:tabdat-status-ignore-hash tabdat)) ;; '() - #f #f ;; offset limit - (dboard:tabdat-hide-not-hide tabdat) ;; not-in - #f #f ;; sort-by sort-order - #f ;; get all? "id,testname,item_path,state,status,event_time,run_duration" ;; qryval - (if (dboard:tabdat-filters-changed tabdat) - 0 - last-update) - *dashboard-mode*) - '()))) ;; get 'em all - ;; (debug:print 0 *default-log-port* "dboard:get-tests-dat: got " (length tdat) " test records for run " run-id) - (sort tdat (lambda (a b) - (let* ((aval (vector-ref a 2)) - (bval (vector-ref b 2)) - (anum (string->number aval)) - (bnum (string->number bval))) - (if (and anum bnum) - (< anum bnum) - (string<= aval bval))))))) +(define (new-tree-path->run-id rdat path) + (if (not (null? path)) + (hash-table-ref/default (dboard:rdat-path-run-ids tabdat) path #f) + #f)) + +;; (define (dboard:get-tests-dat tabdat run-id last-update) +;; (let* ((access-mode (dboard:tabdat-access-mode tabdat)) +;; (tdat (if run-id (db:dispatch-query access-mode rmt:get-tests-for-run db:get-tests-for-run +;; run-id +;; (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "test-name" "%/%") +;; (hash-table-keys (dboard:tabdat-state-ignore-hash tabdat)) ;; '() +;; (hash-table-keys (dboard:tabdat-status-ignore-hash tabdat)) ;; '() +;; #f #f ;; offset limit +;; (dboard:tabdat-hide-not-hide tabdat) ;; not-in +;; #f #f ;; sort-by sort-order +;; #f ;; get all? "id,testname,item_path,state,status,event_time,run_duration" ;; qryval +;; (if (dboard:tabdat-filters-changed tabdat) +;; 0 +;; last-update) +;; *dashboard-mode*) +;; '()))) ;; get 'em all +;; ;; (debug:print 0 *default-log-port* "dboard:get-tests-dat: got " (length tdat) " test records for run " run-id) +;; (sort tdat (lambda (a b) +;; (let* ((aval (vector-ref a 2)) +;; (bval (vector-ref b 2)) +;; (anum (string->number aval)) +;; (bnum (string->number bval))) +;; (if (and anum bnum) +;; (< anum bnum) +;; (string<= aval bval))))))) (define (dashboard:safe-cadr-assoc name lst) (let ((res (assoc name lst))) (if (and res (> (length res) 1)) (cadr res) #f))) (define (dboard:update-tree tabdat runs-hash runs-header tb) - (let* ((run-ids (sort (filter number? (hash-table-keys runs-hash)) + (let* ((access-mode (dboard:tabdat-access-mode tabdat)) + (run-ids (sort (filter number? (hash-table-keys runs-hash)) (lambda (a b) (let* ((record-a (hash-table-ref runs-hash a)) (record-b (hash-table-ref runs-hash b)) (time-a (db:get-value-by-header record-a runs-header "event_time")) (time-b (db:get-value-by-header record-b runs-header "event_time"))) @@ -1409,148 +1889,224 @@ (last-runs-update (dboard:tabdat-last-runs-update tabdat)) (runs-dat (rmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f last-runs-update))) (dboard:tabdat-last-runs-update-set! tabdat (- (current-seconds) 2)) (for-each (lambda (run-id) (let* ((run-record (hash-table-ref/default runs-hash run-id #f)) - (key-vals (map (lambda (key)(db:get-value-by-header run-record runs-header key)) + (key-vals (map (lambda (key) + (let ((val (db:get-value-by-header run-record runs-header key))) + (if (string? val) val ""))) (dboard:tabdat-keys tabdat))) (run-name (db:get-value-by-header run-record runs-header "runname")) (col-name (conc (string-intersperse key-vals "\n") "\n" run-name)) - (run-path (append key-vals (list run-name))) - (existing (tree:find-node tb run-path))) + (run-path (append key-vals (list run-name)))) (if (not (hash-table-ref/default (dboard:tabdat-path-run-ids tabdat) run-path #f)) - (begin - (hash-table-set! (dboard:tabdat-run-keys tabdat) run-id run-path) - ;; (iup:attribute-set! (dboard:tabdat-runs-matrix tabdat) - ;; (conc rownum ":" colnum) col-name) - ;; (hash-table-set! runid-to-col run-id (list colnum run-record)) - ;; Here we update the tests treebox and tree keys - (tree:add-node tb "Runs" run-path ;; (append key-vals (list run-name)) - userdata: (conc "run-id: " run-id)) - (hash-table-set! (dboard:tabdat-path-run-ids tabdat) run-path run-id) - ;; (set! colnum (+ colnum 1)) - )))) + ;; (let ((existing (tree:find-node tb run-path))) + ;; (if (not existing) + (begin + (hash-table-set! (dboard:tabdat-run-keys tabdat) run-id run-path) + ;; (iup:attribute-set! (dboard:tabdat-runs-matrix tabdat) + ;; (conc rownum ":" colnum) col-name) + ;; (hash-table-set! runid-to-col run-id (list colnum run-record)) + ;; Here we update the tests treebox and tree keys + (tree:add-node tb "Runs" run-path) ;; (append key-vals (list run-name)) + ;; userdata: (conc "run-id: " run-id)))) + (hash-table-set! (dboard:tabdat-path-run-ids tabdat) run-path run-id) + ;; (set! colnum (+ colnum 1)) + )))) run-ids))) - -(define (dashboard:one-run-updater commondat tabdat tb cell-lookup run-matrix) - (let* ((last-runs-update (dboard:tabdat-last-runs-update tabdat)) + +(define (dashboard:tests-ht->tests-dat tests-ht) + (let ((oldest-item (make-hash-table))) ;; + ;; populate the oldest-item table + (for-each + (lambda (tdat) + (let ((tname (db:test-get-testname tdat)) + (etime (db:test-get-event_time tdat))) + (if (hash-table-exists? oldest-item tname) + (if (< (hash-table-ref oldest-item tname) etime) + (hash-table-set! oldest-item tname etime)) + (hash-table-set! oldest-item tname etime)))) + (hash-table-values tests-ht)) + (reverse + (sort + (hash-table-values tests-ht) + (lambda (a b) + (let ((a-test-name (db:test-get-testname a)) + (a-item-path (db:test-get-item-path a)) + (b-test-name (db:test-get-testname b)) + (b-item-path (db:test-get-item-path b)) + (a-event-time (db:test-get-event_time a)) + (b-event-time (db:test-get-event_time b))) + (if (equal? a-test-name b-test-name) + (> a-event-time b-event-time) + (> (hash-table-ref oldest-item a-test-name) + (hash-table-ref oldest-item b-test-name))))))))) +;; (if (not (equal? a-test-name b-test-name)) +;; (> a-event-time b-event-time) +;; (cond +;; ((< 0 (string-compare3 a-test-name b-test-name)) #t) +;; ((> 0 (string-compare3 a-test-name b-test-name)) #f) +;; ((< 0 (string-compare3 a-item-path b-item-path)) #t) +;; (else #f))))))))) + + +(define (dashboard:run-id->tests-mindat run-id tabdat runs-hash) + (let* ((run (hash-table-ref/default runs-hash run-id #f)) + (key-vals (rmt:get-key-vals run-id)) + (testnamepatt (or (dboard:tabdat-test-patts tabdat) "%/%")) + (tests-ht (dboard:get-tests-for-run-duplicate tabdat run-id run testnamepatt key-vals)) + (tests-dat (dashboard:tests-ht->tests-dat tests-ht)) + (tests-mindat (dcommon:minimize-test-data tests-dat))) ;; reduces data for display + (dboard:tabdat-last-runs-update-set! tabdat (- (current-seconds) 2)) + (hash-table-set! (dboard:tabdat-last-test-dat tabdat) run-id tests-dat) + (hash-table-set! (dboard:tabdat-run-update-times tabdat) run-id (- (current-seconds) 10)) + (when (not run) + (debug:print-info 13 *default-log-port* "ERROR: NO RUN FOR RUN-ID run-id="run-id) + (debug:print-info 13 *default-log-port* "runs-hash-> " (hash-table->alist runs-hash)) + ) + tests-mindat)) + +(define (dashboard:runs-summary-xor-matrix-content tabdat runs-hash #!key (hide-clean #f)) + (let* ((src-run-id (dboard:tabdat-prev-run-id tabdat)) + (dest-run-id (dboard:tabdat-curr-run-id tabdat))) + (if (and src-run-id dest-run-id) + (dcommon:xor-tests-mindat + (dashboard:run-id->tests-mindat src-run-id tabdat runs-hash) + (dashboard:run-id->tests-mindat dest-run-id tabdat runs-hash) + hide-clean: hide-clean) + #f))) + + +(define (dashboard:get-runs-hash tabdat) + (let* ((access-mode (dboard:tabdat-access-mode tabdat)) + (last-runs-update 0);;(dboard:tabdat-last-runs-update tabdat)) (runs-dat (rmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f last-runs-update)) (runs-header (vector-ref runs-dat 0)) ;; 0 is header, 1 is list of records + (runs (vector-ref runs-dat 1)) (run-id (dboard:tabdat-curr-run-id tabdat)) (runs-hash (let ((ht (make-hash-table))) (for-each (lambda (run) (hash-table-set! ht (db:get-value-by-header run runs-header "id") run)) - (vector-ref runs-dat 1)) - ht))) - (dboard:update-tree tabdat runs-hash runs-header tb) + runs) ht))) + runs-hash)) + + +(define (dashboard:runs-summary-updater commondat tabdat tb cell-lookup run-matrix) + ;; (if (dashboard:database-changed? commondat tabdat context-key: 'runs-summary-rundat) + (dashboard:do-update-rundat tabdat) ;; ) + (dboard:runs-summary-control-panel-updater tabdat) + (let* ((last-runs-update (dboard:tabdat-last-runs-update tabdat)) + (runs-dat (rmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f last-runs-update)) + (runs-header (vector-ref runs-dat 0)) ;; 0 is header, 1 is list of records + (runs (vector-ref runs-dat 1)) + (run-id (dboard:tabdat-curr-run-id tabdat)) + (runs-hash (dashboard:get-runs-hash tabdat)) + ;; (runs-hash (let ((ht (make-hash-table))) + ;; (for-each (lambda (run) + ;; (hash-table-set! ht (db:get-value-by-header run runs-header "id") run)) + ;; runs) + ;; ht)) + ) + (if (dashboard:database-changed? commondat tabdat context-key: 'runs-summary-tree) + (dboard:update-tree tabdat runs-hash runs-header tb)) (if run-id - (let* ( - - (last-update (hash-table-ref/default (dboard:tabdat-run-update-times tabdat) run-id 0)) - (db-path (or (hash-table-ref/default (dboard:tabdat-run-db-paths tabdat) run-id #f) - (let* ((db-dir (tasks:get-task-db-path)) - (db-pth (conc db-dir "/" run-id ".db"))) - (hash-table-set! (dboard:tabdat-run-db-paths tabdat) run-id db-pth) - db-pth))) - (tests-dat (if (or (not run-id) - (configf:lookup *configdat* "setup" "do-not-use-db-file-timestamps") - (not (hash-table-exists? (dboard:tabdat-last-test-dat tabdat) run-id)) - (>= (file-modification-time db-path) last-update)) - (dboard:get-tests-dat tabdat run-id last-update) - (hash-table-ref (dboard:tabdat-last-test-dat tabdat) run-id))) - (tests-mindat (dcommon:minimize-test-data tests-dat)) - (indices (common:sparse-list-generate-index tests-mindat)) ;; proc: set-cell)) - (row-indices (cadr indices)) - (col-indices (car indices)) - (max-row (if (null? row-indices) 1 (common:max (map cadr row-indices)))) - (max-col (if (null? col-indices) 1 (common:max (map cadr col-indices)))) - (max-visible (max (- (dboard:tabdat-num-tests tabdat) 15) 3)) ;; (dboard:tabdat-num-tests tabdat) is proportional to the size of the window - (numrows 1) - (numcols 1) - (changed #f) - ) - (dboard:tabdat-last-runs-update-set! tabdat (- (current-seconds) 2)) - (hash-table-set! (dboard:tabdat-last-test-dat tabdat) run-id tests-dat) - (hash-table-set! (dboard:tabdat-run-update-times tabdat) run-id (- (current-seconds) 10)) - (dboard:tabdat-filters-changed-set! tabdat #f) - (let loop ((pass-num 0) - (changed #f)) - ;; Update the runs tree - (dboard:update-tree tabdat runs-hash runs-header tb) - - (if (eq? pass-num 1) - (begin ;; big reset - (iup:attribute-set! run-matrix "CLEARVALUE" "ALL") ;; NOTE: Was CONTENTS - (iup:attribute-set! run-matrix "CLEARATTRIB" "CONTENTS") - (iup:attribute-set! run-matrix "RESIZEMATRIX" "YES"))) - - (if (> max-col (string->number (iup:attribute run-matrix "NUMCOL"))) - (iup:attribute-set! run-matrix "NUMCOL" max-col )) - - (let ((effective-max-row (if (< max-row max-visible) max-visible max-row))) - (if (> effective-max-row (string->number (iup:attribute run-matrix "NUMLIN"))) - (iup:attribute-set! run-matrix "NUMLIN" effective-max-row ))) - - ;; Row labels - (for-each (lambda (ind) - (let* ((name (car ind)) - (num (cadr ind)) - (key (conc num ":0"))) - (if (not (equal? (iup:attribute run-matrix key) name)) - (begin - (set! changed #t) - (iup:attribute-set! run-matrix key name))))) - row-indices) - ;; (print "row-indices: " row-indices " col-indices: " col-indices) - (if (and (eq? pass-num 0) changed) - (loop 1 #t)) ;; force second pass - - ;; Cell contents - (for-each (lambda (entry) - ;; (print "entry: " entry) - (let* ((row-name (cadr entry)) - (col-name (car entry)) - (valuedat (caddr entry)) - (test-id (list-ref valuedat 0)) - (test-name row-name) ;; (list-ref valuedat 1)) - (item-path col-name) ;; (list-ref valuedat 2)) - (state (list-ref valuedat 1)) - (status (list-ref valuedat 2)) - (value (gutils:get-color-for-state-status state status)) - (row-num (cadr (assoc row-name row-indices))) - (col-num (cadr (assoc col-name col-indices))) - (key (conc row-num ":" col-num))) - (hash-table-set! cell-lookup key test-id) - (if (not (equal? (iup:attribute run-matrix key) (cadr value))) - (begin - (set! changed #t) - (iup:attribute-set! run-matrix key (cadr value)) - (iup:attribute-set! run-matrix (conc "BGCOLOR" key) (car value)))))) - tests-mindat) - - ;; Col labels - do after setting Cell contents so they are accounted for in the size calc. - - (for-each (lambda (ind) - (let* ((name (car ind)) - (num (cadr ind)) - (key (conc "0:" num))) - (if (not (equal? (iup:attribute run-matrix key) name)) - (begin - (set! changed #t) - (iup:attribute-set! run-matrix key name) - (if (<= num max-col) - (iup:attribute-set! run-matrix "FITTOTEXT" (conc "C" num))))))) - col-indices) - - (if (and (eq? pass-num 0) changed) - (loop 1 #t)) ;; force second pass due to column labels changing - - ;; (debug:print 0 *default-log-port* "one-run-updater, changed: " changed " pass-num: " pass-num) - ;; (print "one-run-updater, changed: " changed " pass-num: " pass-num) - (if changed (iup:attribute-set! run-matrix "REDRAW" "ALL")))))) - - ) + (let* ((matrix-content + (case (dboard:tabdat-runs-summary-mode tabdat) + ((one-run) (dashboard:run-id->tests-mindat run-id tabdat runs-hash)) + ((xor-two-runs) (dashboard:runs-summary-xor-matrix-content tabdat runs-hash)) + ((xor-two-runs-hide-clean) (dashboard:runs-summary-xor-matrix-content tabdat runs-hash hide-clean: #t)) + (else (dashboard:run-id->tests-mindat run-id tabdat runs-hash))))) + (when matrix-content + (let* ((indices (common:sparse-list-generate-index matrix-content)) ;; proc: set-cell)) + (row-indices (cadr indices)) + (col-indices (car indices)) + (max-row (if (null? row-indices) 1 (common:max (map cadr row-indices)))) + (max-col (if (null? col-indices) 1 (common:max (map cadr col-indices)))) + (max-visible (max (- (dboard:tabdat-num-tests tabdat) 15) 3)) ;; (dboard:tabdat-num-tests tabdat) is proportional to the size of the window + (numrows 1) + (numcols 1) + (changed #f) + ) + + (dboard:tabdat-filters-changed-set! tabdat #f) + (let loop ((pass-num 0) + (changed #f)) + ;; Update the runs tree + ;; (dboard:update-tree tabdat runs-hash runs-header tb) + + (if (eq? pass-num 1) + (begin ;; big reset + (iup:attribute-set! run-matrix "CLEARVALUE" "ALL") ;; NOTE: Was CONTENTS + (iup:attribute-set! run-matrix "CLEARATTRIB" "CONTENTS") + (iup:attribute-set! run-matrix "RESIZEMATRIX" "YES"))) + + (if (> max-col (string->number (iup:attribute run-matrix "NUMCOL"))) + (iup:attribute-set! run-matrix "NUMCOL" max-col )) + + (let ((effective-max-row (if (< max-row max-visible) max-visible max-row))) + (if (> effective-max-row (string->number (iup:attribute run-matrix "NUMLIN"))) + (iup:attribute-set! run-matrix "NUMLIN" effective-max-row ))) + + (iup:attribute-set! run-matrix "WIDTHDEF" 16) + + ;; Row labels + (for-each (lambda (ind) + (let* ((name (car ind)) + (num (cadr ind)) + (key (conc num ":0"))) + (if (not (equal? (iup:attribute run-matrix key) name)) + (begin + (set! changed #t) + (iup:attribute-set! run-matrix key name))))) + row-indices) + ;; (print "row-indices: " row-indices " col-indices: " col-indices) + (if (and (eq? pass-num 0) changed) + (loop 1 #t)) ;; force second pass + + ;; Cell contents + (for-each (lambda (entry) + ;; (print "entry: " entry) + (let* ((row-name (cadr entry)) + (col-name (car entry)) + (valuedat (caddr entry)) + (test-id (list-ref valuedat 0)) + (test-name row-name) ;; (list-ref valuedat 1)) + (item-path col-name) ;; (list-ref valuedat 2)) + (state (list-ref valuedat 1)) + (status (list-ref valuedat 2)) + (value (gutils:get-color-for-state-status state status)) + (row-num (cadr (assoc row-name row-indices))) + (col-num (cadr (assoc col-name col-indices))) + (key (conc row-num ":" col-num))) + (hash-table-set! cell-lookup key test-id) + (if (not (equal? (iup:attribute run-matrix key) (cadr value))) + (begin + (set! changed #t) + (iup:attribute-set! run-matrix key (cadr value)) + (iup:attribute-set! run-matrix (conc "BGCOLOR" key) (car value)))))) + matrix-content) + + ;; Col labels - do after setting Cell contents so they are accounted for in the size calc. + + (for-each (lambda (ind) + (let* ((name (car ind)) + (num (cadr ind)) + (key (conc "0:" num))) + (if (not (equal? (iup:attribute run-matrix key) name)) + (begin + (set! changed #t) + (iup:attribute-set! run-matrix key name) ;; (list->string (intersperse (string->list name) #\newline))) ;; name) + #;(if (<= num max-col) + (iup:attribute-set! run-matrix "FITTOTEXT" (conc "C" num))))))) + col-indices) + + (if (and (eq? pass-num 0) changed) + (loop 1 #t)) ;; force second pass due to column labels changing + + ;; (debug:print 0 *default-log-port* "runs-summary-updater, changed: " changed " pass-num: " pass-num) + ;; (print "runs-summary-updater, changed: " changed " pass-num: " pass-num) + (if changed (iup:attribute-set! run-matrix "REDRAW" "ALL"))))))))) ;;====================================================================== ;; S U M M A R Y ;;====================================================================== ;; @@ -1558,11 +2114,11 @@ (define (dashboard:summary commondat tabdat #!key (tab-num #f)) (let* ((rawconfig (read-config (conc *toppath* "/megatest.config") #f #f)) ;; changed to #f since I want #{} to be expanded by [system ...] to NOT be expanded. WAS: 'return-string))) (changed #f)) (iup:vbox (iup:split - #:value 500 + #:value 300 (iup:frame #:title "General Info" (iup:vbox (iup:hbox (iup:label "Area Path") @@ -1595,17 +2151,17 @@ (let* ((success #t) ;; at any stage of the process set this flag to #f to skip downstream steps. Intention here is to recover gracefully if user provided tabs fail to load. (source (configf:lookup views-cfgdat view-name "source")) (viewgen (configf:lookup views-cfgdat view-name "viewgen")) (updater (configf:lookup views-cfgdat view-name "updater")) (result-child #f)) - (if (and (file-exists? source) + (if (and (common:file-exists? source) (file-read-access? source)) (handle-exceptions exn (begin (print-call-chain) - (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) + (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn) ", exn=" exn) (debug:print 0 *default-log-port* "ERROR: failed to load " source ", try loading in the repl: megatest -repl") (set! success #f)) (load source)) (begin (debug:print 0 *default-log-port* "ERROR: cannot find file to load: \"" source "\" for user view " view-name))) @@ -1613,11 +2169,11 @@ (if success (handle-exceptions exn (begin (print-call-chain) - (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) + (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn) ", exn=" exn) (debug:print 0 *default-log-port* "ERROR: failed call procedure " viewgen ", with; tab-num=" tab-num ", view-name=" view-name ", and views-cfgdat and megatest configdat as parameters. To debug try loading in the repl: megatest -repl") (set! success #f)) (print "Adding tab " view-name " with proc " viewgen) @@ -1630,98 +2186,259 @@ (lambda () (handle-exceptions exn (begin (print-call-chain) - (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) + (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn) ", exn=" exn) (debug:print 0 *default-log-port* "ERROR: failed call procedure \"" updater - "\", with; tabnum=" tabnum ", view-name=" view-name + "\", with; tabnum=" tab-num ", view-name=" view-name ", and views-cfgdat and megatest configdat as parameters. To debug try loading in the repl: megatest -repl") (set! success #f)) (debug:print 4 *default-log-port* "Running updater for tab " view-name " with proc " updater " and tab-num: " tab-num) ((eval (string->symbol updater)) commondat tabs tab-num view-name views-cfgdat *configdat*))) tab-num: tab-num)) - (if success - (begin - ;; (iup:attribute-set! tabs (conc "TABTITLE" tab-num) view-name) - (dboard:common-set-tabdat! commondat tab-num (dboard:tabdat-make-data)))) + ;;(if success + ;; (begin + ;; ;; (iup:attribute-set! tabs (conc "TABTITLE" tab-num) view-name) + ;; (dboard:common-set-tabdat! commondat tab-num (dboard:tabdat-make-data)))) result-child)) + + + +(define (dboard:runs-summary-buttons-updater tabdat) + (let loop ((buttons-left (dboard:tabdat-runs-summary-mode-buttons tabdat)) + (modes-left (dboard:tabdat-runs-summary-modes tabdat))) + (if (or (null? buttons-left) (null? modes-left)) + #t + (let* ((this-button (car buttons-left)) + (mode-item (car modes-left)) + (this-mode (car mode-item)) + (sel-color "180 100 100") + (nonsel-color "170 170 170") + (current-mode (dboard:tabdat-runs-summary-mode tabdat))) + (if (eq? this-mode current-mode) + (iup:attribute-set! this-button "BGCOLOR" sel-color) + (iup:attribute-set! this-button "BGCOLOR" nonsel-color)) + (loop (cdr buttons-left) (cdr modes-left)))))) + +(define (dboard:runs-summary-xor-labels-updater tabdat) + (let ((source-runname-label (dboard:tabdat-runs-summary-source-runname-label tabdat)) + (dest-runname-label (dboard:tabdat-runs-summary-dest-runname-label tabdat)) + (mode (dboard:tabdat-runs-summary-mode tabdat))) + (when (and source-runname-label dest-runname-label) + (case mode + ((xor-two-runs xor-two-runs-hide-clean) + (let* ((curr-run-id (dboard:tabdat-curr-run-id tabdat)) + (prev-run-id (dboard:tabdat-prev-run-id tabdat)) + (curr-runname (if curr-run-id + (rmt:get-run-name-from-id curr-run-id) + "None")) + (prev-runname (if prev-run-id + (rmt:get-run-name-from-id prev-run-id) + "None"))) + (iup:attribute-set! source-runname-label "TITLE" (conc " SRC: "prev-runname" ")) + (iup:attribute-set! dest-runname-label "TITLE" (conc "DEST: "curr-runname" ")))) + (else + (iup:attribute-set! source-runname-label "TITLE" "") + (iup:attribute-set! dest-runname-label "TITLE" "")))))) + +(define (dboard:runs-summary-control-panel-updater tabdat) + (dboard:runs-summary-xor-labels-updater tabdat) + (dboard:runs-summary-buttons-updater tabdat)) + + +;; setup buttons and callbacks to switch between modes in runs summary tab +;; +(define (dashboard:runs-summary-control-panel tabdat) + (let* ((summary-buttons ;; build buttons + (map + (lambda (mode-item) + (let* ((this-mode (car mode-item)) + (this-mode-label (cdr mode-item))) + (iup:button this-mode-label + #:action + (lambda (obj) + (debug:catch-and-dump + (lambda () + (dboard:tabdat-runs-summary-mode-set! tabdat this-mode) + (dboard:runs-summary-control-panel-updater tabdat)) + "runs summary control panel updater"))))) + (dboard:tabdat-runs-summary-modes tabdat))) + (summary-buttons-hbox (apply iup:hbox summary-buttons)) + (xor-runname-labels-hbox + (iup:hbox + (let ((temp-label + (iup:label "" #:size "125x15" #:fontsize "10" ))) + (dboard:tabdat-runs-summary-source-runname-label-set! tabdat temp-label) + temp-label + ) + (let ((temp-label + (iup:label "" #:size "125x15" #:fontsize "10"))) + (dboard:tabdat-runs-summary-dest-runname-label-set! tabdat temp-label) + temp-label)))) + (dboard:tabdat-runs-summary-mode-buttons-set! tabdat summary-buttons) + + ;; maybe wrap in a frame + (let ((res (iup:vbox summary-buttons-hbox xor-runname-labels-hbox ))) + (dboard:runs-summary-control-panel-updater tabdat) + res + ))) + + ;;====================================================================== ;; R U N ;;====================================================================== ;; ;; display and manage a single run at a time ;; This is the Run Summary tab ;; -(define (dashboard:one-run commondat tabdat #!key (tab-num #f)) +(define (dashboard:runs-summary commondat tabdat #!key (tab-num #f)) (let* ((update-mutex (dboard:commondat-update-mutex commondat)) (tb (iup:treebox #:value 0 - #:name "Runs" + ;;#:name "Runs" + #:title "Runs" ;; was #:name -- iup 3.19 changed this... "Changed: [DEPRECATED REMOVED] removed the old attribute NAMEid from IupTree to avoid conflict with the common attribute NAME. Use the TITLEid attribute." #:expand "YES" - #:addexpanded "NO" + #:addexpanded "YES" #:selection-cb (lambda (obj id state) (debug:catch-and-dump (lambda () ;; (print "obj: " obj ", id: " id ", state: " state) (let* ((run-path (tree:node->path obj id)) (run-id (tree-path->run-id tabdat (cdr run-path)))) (if (number? run-id) (begin + (dboard:tabdat-prev-run-id-set! + tabdat + (dboard:tabdat-curr-run-id tabdat)) + (dboard:tabdat-curr-run-id-set! tabdat run-id) (dboard:tabdat-layout-update-ok-set! tabdat #f) ;; (dashboard:update-run-summary-tab) ) ;; (debug:print-error 0 *default-log-port* "tree-path->run-id returned non-number " run-id) ))) - "selection-cb in one-run") + "selection-cb in runs-summary") ;; (print "path: " (tree:node->path obj id) " run-id: " run-id) ))) (cell-lookup (make-hash-table)) (run-matrix (iup:matrix #:expand "YES" #:click-cb + (lambda (obj lin col status) - (let* ((toolpath (car (argv))) - (key (conc lin ":" col)) - (test-id (hash-table-ref/default cell-lookup key -1)) - (cmd (conc toolpath " -test " (dboard:tabdat-curr-run-id tabdat) "," test-id "&"))) - (system cmd))))) - (one-run-updater + (debug:catch-and-dump + (lambda () + + ;; Bummer - we dont have the global get/set api mapped in chicken + ;; (let* ((modkeys (iup:global "MODKEYSTATE"))) + ;; (BB> "modkeys="modkeys)) + + (debug:print-info 13 *default-log-port* "click-cb: obj="obj" lin="lin" col="col" status="status) + ;; status is corrupted on Brandon's home machine. will have to wait until after shutdown to see if it is still broken in PDX SLES + (let* ((toolpath (car (argv))) + (key (conc lin ":" col)) + (test-id (hash-table-ref/default cell-lookup key -1)) + (run-id (dboard:tabdat-curr-run-id tabdat)) + (run-info (rmt:get-run-info run-id)) + (target (rmt:get-target run-id)) + (runname (db:get-value-by-header (db:get-rows run-info) + (db:get-header run-info) "runname")) + (test-info (rmt:get-test-info-by-id run-id test-id)) + (test-name (db:test-get-testname test-info)) + (testpatt (let ((tlast (rmt:tasks-get-last target runname))) + (if tlast + (let ((tpatt (tasks:task-get-testpatt tlast))) + (if (member tpatt '("0" 0)) ;; known bad historical value - remove in 2017 + "%" + tpatt)) + "%"))) + (item-path (db:test-get-item-path (rmt:get-test-info-by-id run-id test-id))) + (item-test-path (conc test-name "/" (if (equal? item-path "") + "%" + item-path))) + (status-chars (char-set->list (string->char-set status))) + (run-id (dboard:tabdat-curr-run-id tabdat))) + (debug:print-info 13 *default-log-port* "status-chars=["status-chars"] status=["status"]") + (cond + ((member #\1 status-chars) ;; 1 is left mouse button + (dboard:launch-testpanel run-id test-id)) + + ((member #\2 status-chars) ;; 2 is middle mouse button + + (debug:print-info 13 *default-log-port* "mmb- test-name="test-name" testpatt="testpatt) + (iup:show (dashboard:context-menu run-id test-id target runname test-name testpatt item-test-path test-info) ;; popup-menu + #:x 'mouse + #:y 'mouse + #:modal? "NO") + ) + (else + (debug:print-info 13 *default-log-port* "unhandled status in run-summary-click-cb. Doing right click action. (status is corrupted on Brandon's ubuntu host - bad/buggy iup install??" ) + (iup:show (dashboard:context-menu run-id test-id target runname test-name testpatt item-test-path test-info) ;; popup-menu + #:x 'mouse + #:y 'mouse + #:modal? "NO") + ) + ) + + )) "runs-summary-click-callback")))) + (runs-summary-updater (lambda () (mutex-lock! update-mutex) - (if (or (dashboard:database-changed? commondat tabdat) + (if (or (dashboard:database-changed? commondat tabdat context-key: 'runs-summary-updater) (dboard:tabdat-view-changed tabdat)) (debug:catch-and-dump (lambda () ;; check that run-matrix is initialized before calling the updater (if run-matrix - (dashboard:one-run-updater commondat tabdat tb cell-lookup run-matrix))) - "dashboard:one-run-updater") + (dashboard:runs-summary-updater commondat tabdat tb cell-lookup run-matrix))) + "dashboard:runs-summary-updater") ) - (mutex-unlock! update-mutex)))) - (dboard:commondat-add-updater commondat one-run-updater tab-num: tab-num) + (mutex-unlock! update-mutex))) + (runs-summary-control-panel (dashboard:runs-summary-control-panel tabdat)) + ) + (dboard:commondat-add-updater commondat runs-summary-updater tab-num: tab-num) (dboard:tabdat-runs-tree-set! tabdat tb) (iup:vbox (iup:split + #:value 200 tb run-matrix) - (dboard:make-controls commondat tabdat)))) + (dboard:make-controls commondat tabdat extra-widget: runs-summary-control-panel)))) ;;====================================================================== ;; R U N S ;;====================================================================== -(define (dboard:make-controls commondat tabdat) +(define (dboard:squarify toggles size) + (let loop ((hed (car toggles)) + (tal (cdr toggles)) + (cur '()) + (res '())) + (let* ((ovrflo (>= (length cur) size)) + (newcur (if ovrflo + (list hed) + (cons hed cur))) + (newres (if ovrflo + (cons cur res) + res))) + (if (null? tal) + (if ovrflo + newres + (cons newcur res)) + (loop (car tal)(cdr tal) newcur newres))))) + +(define (dboard:make-controls commondat tabdat #!key (extra-widget #f) ) (let ((btn-fontsz (dboard:tabdat-runs-btn-fontsz tabdat))) (iup:hbox (iup:vbox (iup:frame #:title "filter test and items" - (iup:hbox + (iup:vbox + (iup:hbox (iup:vbox (iup:textbox #:size "120x15" #:fontsize "10" #:value "%" #:expand "NO" #:action (lambda (obj unk val) (debug:catch-and-dump @@ -1729,14 +2446,23 @@ (mark-for-update tabdat) (update-search commondat tabdat "test-name" val)) "make-controls"))) (iup:hbox (iup:button "Quit" #:action (lambda (obj) - ;; (if (dboard:tabdat-dblocal tabdat) (db:close-all (dboard:tabdat-dblocal tabdat))) (exit)) #:expand "NO" #:size "40x15") (iup:button "Refresh" #:action (lambda (obj) + (dboard:tabdat-last-data-update-set! tabdat 0) + (dboard:tabdat-last-runs-update-set! tabdat 0) + (dboard:tabdat-run-update-times-set! tabdat (make-hash-table)) + (dboard:tabdat-last-test-dat-set! tabdat (make-hash-table)) + (dboard:tabdat-allruns-set! tabdat '()) + (dboard:tabdat-allruns-by-id-set! tabdat (make-hash-table)) + (dboard:tabdat-done-runs-set! tabdat '()) + (dboard:tabdat-not-done-runs-set! tabdat '()) + (dboard:tabdat-view-changed-set! tabdat #t) + (dboard:commondat-please-update-set! commondat #t) (mark-for-update tabdat)) #:expand "NO" #:size "40x15") (iup:button "Collapse" #:action (lambda (obj) (debug:catch-and-dump (lambda () @@ -1772,178 +2498,279 @@ #:dropdown "YES" #:action (lambda (obj val index lbstate) (set! *tests-sort-reverse* index) (mark-for-update tabdat)))) (default-cmd (car (list-ref *tests-sort-type-index* *tests-sort-reverse*)))) + (iuplistbox-fill-list sort-lb cmds-list selected-item: default-cmd) - (set! hide-empty (iup:button "HideEmpty" - ;; #:expand HORIZONTAL" - #:expand "NO" #:size "80x15" - #:action (lambda (obj) - (dboard:tabdat-hide-empty-runs-set! tabdat (not (dboard:tabdat-hide-empty-runs tabdat))) - (iup:attribute-set! obj "TITLE" (if (dboard:tabdat-hide-empty-runs tabdat) "+HideE" "-HideE")) - (mark-for-update tabdat)))) + ;; (set! hide-empty (iup:button "HideEmpty" + ;; ;; #:expand HORIZONTAL" + ;; #:expand "NO" #:size "80x15" + ;; #:action (lambda (obj) + ;; (dboard:tabdat-hide-empty-runs-set! tabdat (not (dboard:tabdat-hide-empty-runs tabdat))) + ;; (iup:attribute-set! obj "TITLE" (if (dboard:tabdat-hide-empty-runs tabdat) "+HideE" "-HideE")) + ;; (mark-for-update tabdat)))) (set! hide (iup:button "Hide" #:expand "NO" #:size "40x15" ;; #:expand "HORIZONTAL" #:action (lambda (obj) (dboard:tabdat-hide-not-hide-set! tabdat #t) ;; (not (dboard:tabdat-hide-not-hide tabdat))) ;; (iup:attribute-set! obj "TITLE" (if (dboard:tabdat-hide-not-hide tabdat) "HideTests" "NotHide")) - (iup:attribute-set! hide "BGCOLOR" sel-color) - (iup:attribute-set! show "BGCOLOR" nonsel-color) + (iup:attribute-set! hide "FGCOLOR" sel-color) + (iup:attribute-set! show "FGCOLOR" nonsel-color) (mark-for-update tabdat)))) (set! show (iup:button "Show" #:expand "NO" #:size "40x15" ;; #:expand "HORIZONTAL" #:action (lambda (obj) (dboard:tabdat-hide-not-hide-set! tabdat #f) ;; (not (dboard:tabdat-hide-not-hide tabdat))) - (iup:attribute-set! show "BGCOLOR" sel-color) - (iup:attribute-set! hide "BGCOLOR" nonsel-color) + (iup:attribute-set! show "FGCOLOR" sel-color) + (iup:attribute-set! hide "FGCOLOR" nonsel-color) (mark-for-update tabdat)))) - (iup:attribute-set! hide "BGCOLOR" sel-color) - (iup:attribute-set! show "BGCOLOR" nonsel-color) + (iup:attribute-set! hide "FGCOLOR" sel-color) + (iup:attribute-set! show "FGCOLOR" nonsel-color) ;; (dboard:tabdat-hide-not-hide-button-set! tabdat hideit) ;; never used, can eliminate ... - (iup:vbox - (iup:hbox hide show) - hide-empty sort-lb))) - ))) - (iup:frame - #:title "state/status filter" - (iup:vbox - (apply - iup:hbox - (map (lambda (status) - (iup:toggle (conc status " ") - #:fontsize btn-fontsz ;; "10" - #:expand "HORIZONTAL" - #:action (lambda (obj val) - (mark-for-update tabdat) - (if (eq? val 1) - (hash-table-set! (dboard:tabdat-status-ignore-hash tabdat) status #t) - (hash-table-delete! (dboard:tabdat-status-ignore-hash tabdat) status)) - (set-bg-on-filter commondat tabdat)))) - (map cadr *common:std-statuses*))) ;; '("PASS" "FAIL" "WARN" "CHECK" "WAIVED" "STUCK/DEAD" "n/a" "SKIP"))) - (apply - iup:hbox - (map (lambda (state) - (iup:toggle (conc state " ") - #:fontsize btn-fontsz - #:expand "HORIZONTAL" - #:action (lambda (obj val) - (mark-for-update tabdat) - (if (eq? val 1) - (hash-table-set! (dboard:tabdat-state-ignore-hash tabdat) state #t) - (hash-table-delete! (dboard:tabdat-state-ignore-hash tabdat) state)) - (set-bg-on-filter commondat tabdat)))) - (map cadr *common:std-states*))) ;; '("RUNNING" "COMPLETED" "INCOMPLETE" "LAUNCHED" "NOT_STARTED" "KILLED" "DELETED"))) - (iup:valuator #:valuechanged_cb (lambda (obj) - (let ((val (inexact->exact (round (/ (string->number (iup:attribute obj "VALUE")) 10)))) - (oldmax (string->number (iup:attribute obj "MAX"))) - (maxruns (dboard:tabdat-tot-runs tabdat))) - (dboard:tabdat-start-run-offset-set! tabdat val) - (mark-for-update tabdat) - (debug:print 6 *default-log-port* "(dboard:tabdat-start-run-offset tabdat) " (dboard:tabdat-start-run-offset tabdat) " maxruns: " maxruns ", val: " val " oldmax: " oldmax) - (iup:attribute-set! obj "MAX" (* maxruns 10)))) - #:expand "HORIZONTAL" - #:max (* 10 (max (hash-table-size (dboard:tabdat-allruns-by-id tabdat)) 10)) - #:min 0 - #:step 0.01))) - ;(iup:button "inc rows" #:action (lambda (obj)(dboard:tabdat-num-tests-set! tabdat (+ (dboard:tabdat-num-tests tabdat) 1)))) - ;(iup:button "dec rows" #:action (lambda (obj)(dboard:tabdat-num-tests-set! tabdat (if (> (dboard:tabdat-num-tests tabdat) 0)(- (dboard:tabdat-num-tests tabdat) 1) 0)))) - ))) - -(define (dashboard:popup-menu buttndat run-id test-id target runname test-name testpatt item-test-path) - (iup:menu - (iup:menu-item - "Run" - (iup:menu - (iup:menu-item - (conc "Rerun " testpatt) - #:action - (lambda (obj) - ;; (print "buttndat: " buttndat " run-id: " run-id " test-id: " test-id " target: " target " runname: " runname " test-name: " test-name " testpatt: " testpatt "item-path : " item-path) - (common:run-a-command - (conc "megatest -run -target " target - " -runname " runname - " -testpatt " testpatt - " -preclean -clean-cache") - ))) - (iup:menu-item - "Rerun Complete Run" - #:action - (lambda (obj) - (common:run-a-command - (conc "megatest -set-state-status NOT_STARTED,n/a -run -target " target - " -runname " runname - " -testpatt % " - " -preclean -clean-cache")))) - (iup:menu-item - "Clean Complete Run" - #:action - (lambda (obj) - (common:run-a-command - (conc "megatest -remove-runs -target " target - " -runname " runname - " -testpatt % ")))))) - (iup:menu-item - "Test" - (iup:menu - (iup:menu-item - (conc "Rerun " item-test-path) - #:action - (lambda (obj) - (common:run-a-command - (conc "megatest -set-state-status NOT_STARTED,n/a -run -target " target - " -runname " runname - " -testpatt " item-test-path - " -preclean -clean-cache")))) - (iup:menu-item - (conc "Kill " item-test-path) - #:action - (lambda (obj) - ;; (rmt:test-set-state-status-by-id run-id test-id "KILLREQ" #f #f) - (common:run-a-command - (conc "megatest -set-state-status KILLREQ,n/a -target " target - " -runname " runname - " -testpatt " item-test-path - " -state RUNNING,REMOTEHOSTSTART,LAUNCHED")))) - (iup:menu-item - (conc "Clean "item-test-path) - #:action - (lambda (obj) - (common:run-a-command - (conc "megatest -remove-runs -target " target - " -runname " runname - " -testpatt " item-test-path)))) - (iup:menu-item - "Start xterm" - #:action - (lambda (obj) - (dcommon:examine-xterm run-id test-id))) - ;;(let* ((cmd (conc (car (argv)) " -xterm " run-id "," test-id "&"))) - ;; (system cmd)))) - (iup:menu-item - "Edit testconfig" - #:action - (lambda (obj) - (let* ((all-tests (tests:get-all)) - (editor-rx (or (configf:lookup *configdat* "setup" "editor-regex") - "\\b(vim?|nano|pico)\\b")) - (editor (or (configf:lookup *configdat* "setup" "editor") - (get-environment-variable "VISUAL") - (get-environment-variable "EDITOR") "vi")) - (tconfig (conc (hash-table-ref all-tests test-name) "/testconfig")) - (cmd (conc (if (string-search editor-rx editor) - (conc "xterm -e " editor) - editor) - " " tconfig " &"))) - (system cmd)))) - )))) + (iup:vbox + (iup:hbox hide show) + sort-lb))) + ) + + ;; insert extra widget here + (if extra-widget + extra-widget + (iup:hbox)) ;; empty widget + + + + + ))) + + (let* ((status-toggles (map (lambda (status) + (iup:toggle (conc status) + #:fontsize 8 ;; btn-fontsz ;; "10" + ;; #:expand "HORIZONTAL" + #:action (lambda (obj val) + (mark-for-update tabdat) + (if (eq? val 1) + (hash-table-set! (dboard:tabdat-status-ignore-hash tabdat) status #t) + (hash-table-delete! (dboard:tabdat-status-ignore-hash tabdat) status)) + (set-bg-on-filter commondat tabdat)))) + (map cadr *common:std-statuses*))) ;; '("PASS" "FAIL" "WARN" "CHECK" "WAIVED" "STUCK/DEAD" "n/a" "SKIP"))) + (state-toggles (map (lambda (state) + (iup:toggle (conc state) + #:fontsize 8 ;; btn-fontsz + ;; #:expand "HORIZONTAL" + #:action (lambda (obj val) + (mark-for-update tabdat) + (if (eq? val 1) + (hash-table-set! (dboard:tabdat-state-ignore-hash tabdat) state #t) + (hash-table-delete! (dboard:tabdat-state-ignore-hash tabdat) state)) + (set-bg-on-filter commondat tabdat)))) + (map cadr *common:std-states*))) ;; '("RUNNING" "COMPLETED" "INCOMPLETE" "LAUNCHED" "NOT_STARTED" "KILLED" "DELETED"))) + (num-toggle-cols (inexact->exact (round (/ (max (length status-toggles)(length state-toggles)) 3))))) + (iup:vbox + (iup:hbox + (iup:frame + #:title "states" + (apply + iup:hbox + (map (lambda (colgrp) + (apply iup:vbox colgrp)) + (dboard:squarify state-toggles 3)))) + (iup:frame + #:title "statuses" + (apply + iup:hbox + (map (lambda (colgrp) + (apply iup:vbox colgrp)) + (dboard:squarify status-toggles 3))))) + ;; + ;; (iup:frame + ;; #:title "state/status filter" + ;; (iup:vbox + ;; (apply + ;; iup:hbox + ;; (map + ;; (lambda (status-toggle state-toggle) + ;; (iup:vbox + ;; status-toggle + ;; state-toggle)) + ;; status-toggles state-toggles)) + + ;; horizontal slider was here + + ))))) + +(define (dashboard:runs-horizontal-slider tabdat ) + (iup:valuator #:valuechanged_cb (lambda (obj) + (let ((val (inexact->exact (round (/ (string->number (iup:attribute obj "VALUE")) 10)))) + (oldmax (string->number (iup:attribute obj "MAX"))) + (maxruns (dboard:tabdat-tot-runs tabdat))) + (dboard:tabdat-start-run-offset-set! tabdat val) + (mark-for-update tabdat) + (debug:print 6 *default-log-port* "(dboard:tabdat-start-run-offset tabdat) " (dboard:tabdat-start-run-offset tabdat) " maxruns: " maxruns ", val: " val " oldmax: " oldmax) + (iup:attribute-set! obj "MAX" (* maxruns 10)))) + #:expand "HORIZONTAL" + #:max (* 10 (max (hash-table-size (dboard:tabdat-allruns-by-id tabdat)) 10)) + #:min 0 + #:step 0.01)) + +;; make-simple-run procedure (target3772 id3773 runname3774 state3775 status3776 owner3777 event_time3778) +;; rmt:simple-get-runs procedure (runpatt1001 count1002 offset1003 target1004) +;; simple-run-event_time procedure (x3834) +;; simple-run-event_time-set! procedure (x3830 val3831) +;; simple-run-id procedure (x3794) +;; simple-run-id-set! procedure (x3790 val3791) +;; simple-run-owner procedure (x3826) +;; simple-run-owner-set! procedure (x3822 val3823) +;; simple-run-runname procedure (x3802) +;; simple-run-runname-set! procedure (x3798 val3799) +;; simple-run-state procedure (x3810) +;; simple-run-state-set! procedure (x3806 val3807) +;; simple-run-status procedure (x3818) +;; simple-run-status-set! procedure (x3814 val3815) +;; simple-run-target procedure (x3786) +;; simple-run-target-set! procedure (x3782 val3783) +;; simple-run? procedure (x3780) + + +;;====================================================================== +;; Extracting the data to display for runs +;; +;; This needs to be re-entrant such that it does one column per call +;; on the zeroeth call update runs data +;; on each subsequent call update one run (configurable - could do two, three ... or update until tdelta exceeded +;; on last run reset to zeroeth +;; +;; 1. select with run filters; area, target, runname, runstate, runstatus, starttime, duration +;; - put this information into two data structures: +;; a. hash of area/target/runname => runstruct #< ordernun, id, area, target, runname, state, +;; status, starttime, duration, non-deleted testcount> +;; ordernum reflects order as received from sql query +;; b. sparsevec of id => runstruct +;; 2. for each run in runshash ordered by ordernum do: +;; retrieve data since last update for that run +;; if there is a deleted test - retrieve full data +;; if there are non-deleted tests register this run in the columns sparsevec +;; if this is the zeroeth column regenerate the rows sparsevec +;; if this column is in the visible zone update visible cells +;; +;; Other factors: +;; 1. left index handling: +;; - add test/itempaths to left index as discovered, re-order and +;; update row -> test/itempath mapping on each read run +;;====================================================================== + +;; runs is +;; get ALL runs info +;; update rdat-targ-run-id +;; update rdat-runs +;; +(define (dashboard:update-runs-data rdat) + (let* ((tb (dboard:rdat-runs-tree rdat)) + (targ-sql-filt (dboard:rdat-targ-sql-filt rdat)) + (runname-sql-filt (dboard:rdat-runname-sql-filt rdat)) + (state-sql-filt (dboard:rdat-run-state-sql-filt rdat)) + (status-sql-filt (dboard:rdat-run-status-sql-filt rdat)) + ;; Use (db:get-value-by-header (db:get-header runinfo)(db:get-rows runinfo)) + (data (rmt:simple-get-runs runname-sql-filt #f #f targ-sql-filt #f)) + (numruns (length data))) + ;; store in the runsbynum vector + (dboard:rdat-runsbynum-set! rdat (list->vector data)) + ;; update runs id => runrec + ;; update targ-runid target/runname => run-id + (for-each + (lambda (runrec) + (let* ((run-id (simple-run-id runrec)) + (full-targ-runname (conc (simple-run-target runrec) "/" + (simple-run-runname runrec)))) + (debug:print 0 *default-log-port* "Update run " run-id) + (sparse-vector-set! (dboard:rdat-runs rdat) run-id runrec) + (hash-table-set! (dboard:rdat-targ-runid rdat) full-targ-runname run-id) + )) + data) + numruns)) + +;; NOTE: runnum is NOT the run-id, it is a pointer into the runsbynum vector +;; +(define (dashboard:update-run-data runnum rdat) + (let* ((curr-time (current-seconds)) + (runrec (vector-ref (dboard:rdat-runsbynum rdat) runnum)) + (run-id (simple-run-id runrec)) + (last-update (sparse-vector-ref (dboard:rdat-last-updates rdat) run-id)) + ;; filters + (testname-sql-filt (dboard:rdat-testname-sql-filt rdat)) + ;; (itempath-sql-filt (dboard:rdat-itempath-sql-filt rdat)) + (test-state-sql-filt (dboard:rdat-test-state-sql-filt rdat)) ;; not used yet + (test-status-sql-filt (dboard:rdat-test-status-sql-filt rdat)) ;; not used yet + (tests (rmt:get-tests-for-run-state-status run-id + testname-sql-filt + last-update ;; last-update + ))) + (sparse-vector-set! (dboard:rdat-last-updates rdat) run-id (- curr-time 1)) + (debug:print 0 *default-log-port* "Got " (length tests) " tests for run-id " + run-id " testname-sql-filt " testname-sql-filt " and last-update " last-update) + (length tests))) + +(define (new-runs-updater commondat rdat) + (let* ((runnum (dboard:rdat-runnum rdat)) + (start-time (current-milliseconds)) + (tot-runs #f)) + (if (eq? runnum 0)(dashboard:update-runs-data rdat)) + (set! tot-runs (vector-length (dboard:rdat-runsbynum rdat))) + (let loop ((rn runnum)) + (if (and (< (- (current-milliseconds) start-time) 250) + (< rn tot-runs)) + (let* ((newrn (if (>= runnum (vector-length (dboard:rdat-runsbynum rdat))) + 0 ;; start over + (+ rn 1)))) ;; (+ runnum 1))) + (dashboard:update-run-data rn rdat) + (dboard:rdat-runnum-set! rdat newrn) + (if (> newrn 0) + (loop newrn))))) + (if (>= (dboard:rdat-runnum rdat) tot-runs) + (dboard:rdat-runnum-set! rdat 0)) + ;; (dboard:rdat-runnum-set! rdat rn))) ;; not needed as it is set above + ;; (dboard:rdat-last-update-set! rdat (- (current-seconds) 10)) + ;; (tree:add-node tb "Runs" (string-split full-targ-runname "/")) + '())) + +(define (dboard:runs-new-matrix commondat rdat) + (iup:matrix + #:alignment1 "ALEFT" + ;; #:expand "YES" ;; "HORIZONTAL" + #:scrollbar "YES" + #:numcol 10 + #:numlin 20 + #:numcol-visible 5 ;; (min 8) + #:numlin-visible 1 + #:click-cb + (lambda (obj row col status) + (let* ((cell (conc row ":" col))) + #f)) + )) + +(define (make-runs-view commondat rdat tab-num) + ;; register an updater + (dboard:commondat-add-updater + commondat + (lambda () + (new-runs-updater commondat rdat)) + tab-num: tab-num) + + (iup:vbox + (iup:split + #:orientation "VERTICAL" ;; "HORIZONTAL" + #:value 100 + (dboard:runs-tree-new-browser commondat rdat) + (dboard:runs-new-matrix commondat rdat) + ))) (define (make-dashboard-buttons commondat) ;; runs-sum-dat new-view-dat) (let* ((stats-dat (dboard:tabdat-make-data)) (runs-dat (dboard:tabdat-make-data)) - (onerun-dat (dboard:tabdat-make-data)) + (runs2-dat (make-dboard:rdat)) ;; (dboard:tabdat-make-data)) + (onerun-dat (dboard:tabdat-make-data)) ;; name for run-summary structure (runcontrols-dat (dboard:tabdat-make-data)) (runtimes-dat (dboard:tabdat-make-data)) (nruns (dboard:tabdat-numruns runs-dat)) (ntests (dboard:tabdat-num-tests runs-dat)) (keynames (dboard:tabdat-dbkeys runs-dat)) @@ -1962,57 +2789,90 @@ (btn-fontsz (dboard:tabdat-runs-btn-fontsz runs-dat)) (cell-width (dboard:tabdat-runs-cell-width runs-dat))) ;; controls (along bottom) ;; (set! controls (dboard:make-controls commondat runs-dat)) + (if (args:get-arg "-runname") + (let ((runname (args:get-arg "-runname"))) + (update-search commondat runs-dat "runname" runname) + #;(hash-table-set! (dboard:tabdat-searchpatts tabdat) "runname" runname))) + ;; create the left most column for the run key names and the test names - (set! lftlst (list (iup:hbox - (iup:label) ;; (iup:valuator) - (apply iup:vbox - (map (lambda (x) - (let ((res (iup:hbox #:expand "HORIZONTAL" - (iup:label x #:size (conc 40 btn-height) #:fontsize btn-fontsz #:expand "NO") ;; "HORIZONTAL") - (iup:textbox #:size (conc 35 btn-height) #:fontsize btn-fontsz #:value "%" #:expand "NO" ;; "HORIZONTAL" - #:action (lambda (obj unk val) - (mark-for-update runs-dat) - (update-search commondat runs-dat x val)))))) - (set! i (+ i 1)) - res)) - keynames))))) + (set! lftlst + (list (iup:hbox + (iup:label) ;; (iup:valuator) + (apply iup:vbox + (map (lambda (x) + (let ((res (iup:hbox + #:expand "HORIZONTAL" + (iup:label x + #:size (conc 40 btn-height) + #:fontsize btn-fontsz + #:expand "NO") ;; "HORIZONTAL") + (iup:textbox + #:size (conc 35 btn-height) + #:fontsize btn-fontsz + #:value (if (and (args:get-arg "-runname")(equal? x "runname")) + (args:get-arg "-runname") "%") + #:expand "NO" ;; "HORIZONTAL" + #:action (lambda (obj unk val) + ;; each field + ;; (field name is "x" var) live updates + ;; the search filter as it is typed + (dboard:tabdat-target-set! runs-dat #f) + ;; ensure fields text boxes are used + ;; and not the info from the tree + (mark-for-update runs-dat) + (update-search commondat runs-dat x val)))))) + (set! i (+ i 1)) + res)) + keynames))))) (let loop ((testnum 0) (res '())) (cond ((>= testnum ntests) ;; now lftlst will be an hbox with the test keys and the test name labels - (set! lftlst (append lftlst (list (iup:hbox #:expand "HORIZONTAL" - (iup:valuator #:valuechanged_cb (lambda (obj) - (let ((val (string->number (iup:attribute obj "VALUE"))) - (oldmax (string->number (iup:attribute obj "MAX"))) - (newmax (* 10 (length (dboard:tabdat-all-test-names runs-dat))))) - (dboard:commondat-please-update-set! commondat #t) - (dboard:tabdat-start-test-offset-set! runs-dat (inexact->exact (round (/ val 10)))) - (debug:print 6 *default-log-port* "(dboard:tabdat-start-test-offset runs-dat) " (dboard:tabdat-start-test-offset runs-dat) " val: " val " newmax: " newmax " oldmax: " oldmax) - (if (< val 10) - (iup:attribute-set! obj "MAX" newmax)) - )) - #:expand "VERTICAL" - #:orientation "VERTICAL" - #:min 0 - #:step 0.01) - (apply iup:vbox (reverse res))))))) + (set! lftlst + (append + lftlst + (list + (iup:hbox + #:expand "HORIZONTAL" + (iup:valuator + #:valuechanged_cb + (lambda (obj) + (let ((val (string->number (iup:attribute obj "VALUE"))) + (oldmax (string->number (iup:attribute obj "MAX"))) + (newmax (* 10 (length (dboard:tabdat-all-test-names runs-dat))))) + (dboard:commondat-please-update-set! commondat #t) + (dboard:tabdat-start-test-offset-set! runs-dat + (inexact->exact (round (/ val 10)))) + (debug:print 6 *default-log-port* + "(dboard:tabdat-start-test-offset runs-dat) " + (dboard:tabdat-start-test-offset runs-dat) " val: " val + " newmax: " newmax " oldmax: " oldmax) + (if (< val 10) + (iup:attribute-set! obj "MAX" newmax)) + )) + #:expand "VERTICAL" + #:orientation "VERTICAL" + #:min 0 + #:step 0.01) + (apply iup:vbox (reverse res))))))) (else - (let ((labl (iup:button "" ;; the testname labels - #:flat "YES" - #:alignment "ALEFT" + (let ((labl (iup:button + "" ;; the testname labels + #:flat "YES" + #:alignment "ALEFT" ; #:image img1 ; #:impress img2 - #:size (conc cell-width btn-height) - #:expand "HORIZONTAL" - #:fontsize btn-fontsz - #:action (lambda (obj) - (mark-for-update runs-dat) - (toggle-hide testnum (dboard:commondat-uidat commondat)))))) ;; (iup:attribute obj "TITLE")))) + #:size (conc cell-width btn-height) + #:expand "HORIZONTAL" + #:fontsize btn-fontsz + #:action (lambda (obj) + (mark-for-update runs-dat) + (toggle-hide testnum (dboard:commondat-uidat commondat)))))) (vector-set! lftcol testnum labl) (loop (+ testnum 1)(cons labl res)))))) ;; These are the headers for each row (let loop ((runnum 0) (keynum 0) @@ -2023,11 +2883,11 @@ ((>= keynum nkeys) (vector-set! header runnum keyvec) (set! hdrlst (cons (apply iup:vbox (reverse res)) hdrlst)) (loop (+ runnum 1) 0 (make-vector nkeys) '())) (else - (let ((labl (iup:label "" #:size (conc cell-width btn-height) #:fontsize btn-fontsz #:expand "NO"))) ;; #:expand "HORIZONTAL" "60x15" + (let ((labl (iup:label "" #:size (conc cell-width btn-height) #:fontsize btn-fontsz #:expand "HORIZONTAL"))) ;; #:expand "HORIZONTAL" "60x15" (vector-set! keyvec keynum labl) (loop runnum (+ keynum 1) keyvec (cons labl res)))))) ;; By here the hdrlst contains a list of vboxes containing nkeys labels (let loop ((runnum 0) (testnum 0) @@ -2042,11 +2902,12 @@ (else (let* ((button-key (mkstr runnum testnum)) (butn (iup:button "" ;; button-key #:size (conc cell-width btn-height ) - #:expand "NO" + #:expand "HORIZONTAL" + #:MARKUP "YES" #:fontsize btn-fontsz #:button-cb (lambda (obj a pressed x y btn . rem) ;; (print "pressed= " pressed " x= " x " y= " y " rem=" rem " btn=" btn " string? " (string? btn)) (if (substring-index "3" btn) @@ -2057,11 +2918,12 @@ (run-id (db:test-get-run_id (vector-ref buttndat 3))) (run-info (rmt:get-run-info run-id)) (target (rmt:get-target run-id)) (runname (db:get-value-by-header (db:get-rows run-info) (db:get-header run-info) "runname")) - (test-name (db:test-get-testname (rmt:get-test-info-by-id run-id test-id))) + (test-info (rmt:get-test-info-by-id run-id test-id)) + (test-name (db:test-get-testname test-info)) (testpatt (let ((tlast (rmt:tasks-get-last target runname))) (if tlast (let ((tpatt (tasks:task-get-testpatt tlast))) (if (member tpatt '("0" 0)) ;; known bad historical value - remove in 2017 "%" @@ -2069,24 +2931,22 @@ "%"))) (item-path (db:test-get-item-path (rmt:get-test-info-by-id run-id test-id))) (item-test-path (conc test-name "/" (if (equal? item-path "") "%" item-path)))) - (iup:show (dashboard:popup-menu buttndat run-id test-id target runname test-name testpatt item-test-path) ;; popup-menu + (iup:show (dashboard:context-menu run-id test-id target runname test-name testpatt item-test-path test-info) ;; popup-menu #:x 'mouse #:y 'mouse #:modal? "NO") ;; (print "got here") )) (if (eq? pressed 0) (let* ((toolpath (car (argv))) (buttndat (hash-table-ref (dboard:tabdat-buttondat runs-dat) button-key)) (test-id (db:test-get-id (vector-ref buttndat 3))) - (run-id (db:test-get-run_id (vector-ref buttndat 3))) - (cmd (conc toolpath " -test " run-id "," test-id "&"))) - (system cmd))) - ))))) + (run-id (db:test-get-run_id (vector-ref buttndat 3)))) + (dboard:launch-testpanel run-id test-id)))))))) (hash-table-set! (dboard:tabdat-buttondat runs-dat) button-key (vector 0 "100 100 100" button-key #f #f)) (vector-set! testvec testnum butn) (loop runnum (+ testnum 1) testvec (cons butn res)))))) ;; now assemble the hdrlst and bdylst and kick off the dialog (iup:show @@ -2094,20 +2954,23 @@ #:title (conc "Megatest dashboard " (current-user-name) ":" *toppath*) #:menu (dcommon:main-menu) (let* ((runs-view (iup:vbox (iup:split #:orientation "VERTICAL" ;; "HORIZONTAL" - #:value 150 + #:value 100 (dboard:runs-tree-browser commondat runs-dat) (iup:split + #:value 100 ;; left most block, including row names (apply iup:vbox lftlst) ;; right hand block, including cells (iup:vbox + #:expand "YES" ;; the header (apply iup:hbox (reverse hdrlst)) - (apply iup:hbox (reverse bdylst))))) + (apply iup:hbox (reverse bdylst)) + (dashboard:runs-horizontal-slider runs-dat)))) controls )) (views-cfgdat (common:load-views-config)) (additional-tabnames '()) (tab-start-num 5) ;; DON'T FORGET TO UPDATE THIS WHEN CHANGING THE STANDARD TABS BELOW @@ -2119,23 +2982,26 @@ (lambda (view-name) (debug:print 0 *default-log-port* "Adding view " view-name) (let* ((cfgtype (configf:lookup views-cfgdat view-name "type"))) ;; what type of view? (if (not (string? cfgtype)) (debug:print-info 0 *default-log-port* "WARNING: view \"" view-name - "\" is missing needed sections. Please consult the documenation and update ~/.mtviews.config or " *toppath* "/.mtviews.config") + "\" is missing needed sections. " + "Please consult the documenation and update ~/.mtviews.config or " + *toppath* "/.mtviews.config") (case (string->symbol cfgtype) ;; user supplied source for a tab ;; - ((external) - (let ((tab-content (dboard:add-external-tab commondat view-name views-cfgdat #f tab-num))) ;; was tabs + ((external) ;; was tabs + (let ((tab-content (dboard:add-external-tab commondat view-name views-cfgdat #f tab-num))) (set! additional-tabnames (cons (cons tab-num view-name) additional-tabnames)) (set! tab-num (+ tab-num 1)) (set! result (append result (list tab-content))))))))) - (sort (hash-table-keys views-cfgdat) (lambda (a b) - (let ((order-a (or (any->number (configf:lookup views-cfgdat a "order")) 999)) - (order-b (or (any->number (configf:lookup views-cfgdat b "order")) 999))) - (> order-a order-b))))) + (sort (hash-table-keys views-cfgdat) + (lambda (a b) + (let ((order-a (or (any->number (configf:lookup views-cfgdat a "order")) 999)) + (order-b (or (any->number (configf:lookup views-cfgdat b "order")) 999))) + (> order-a order-b))))) result)) (tabs (apply iup:tabs #:tabchangepos-cb (lambda (obj curr prev) (debug:catch-and-dump (lambda () @@ -2148,18 +3014,19 @@ (dboard:commondat-please-update-set! commondat #t) (dboard:tabdat-layout-update-ok-set! tabdat #t))) "tabchangepos")) (dashboard:summary commondat stats-dat tab-num: 0) runs-view - (dashboard:one-run commondat onerun-dat tab-num: 2) - ;; (dashboard:new-view db data new-view-dat tab-num: 3) + ;; (make-runs-view commondat runs2-dat 2) + (dashboard:runs-summary commondat onerun-dat tab-num: 2) (dashboard:run-controls commondat runcontrols-dat tab-num: 3) (dashboard:run-times commondat runtimes-dat tab-num: 4) additional-views))) ;; (set! (iup:callback tabs tabchange-cb:) (lambda (a b c)(print "SWITCHED TO TAB: " a " " b " " c))) (iup:attribute-set! tabs "TABTITLE0" "Summary") (iup:attribute-set! tabs "TABTITLE1" "Runs") + ;; (iup:attribute-set! tabs "TABTITLE2" "Runs2") (iup:attribute-set! tabs "TABTITLE2" "Run Summary") (iup:attribute-set! tabs "TABTITLE3" "Run Control") (iup:attribute-set! tabs "TABTITLE4" "Run Times") ;; (iup:attribute-set! tabs "TABTITLE3" "New View") ;; (iup:attribute-set! tabs "TABTITLE4" "Run Control") @@ -2174,10 +3041,11 @@ ;; make the iup tabs object available (for changing color for example) (dboard:commondat-hide-not-hide-tabs-set! commondat tabs) ;; now set up the tabdat lookup (dboard:common-set-tabdat! commondat 0 stats-dat) (dboard:common-set-tabdat! commondat 1 runs-dat) + ;;(dboard:common-set-tabdat! commondat 2 runs2-dat) (dboard:common-set-tabdat! commondat 2 onerun-dat) (dboard:common-set-tabdat! commondat 3 runcontrols-dat) (dboard:common-set-tabdat! commondat 4 runtimes-dat) (iup:vbox @@ -2192,47 +3060,42 @@ (get-environment-variable "DASHBOARDROWS") "15")))) (define *tim* (iup:timer)) (define *ord* #f) -(iup:attribute-set! *tim* "TIME" 300) +(iup:attribute-set! *tim* "TIME" (or (configf:lookup *configdat* "dashboard" "poll-interval") "1000")) (iup:attribute-set! *tim* "RUN" "YES") (define *last-recalc-ended-time* 0) -(define (dashboard:been-changed tabdat) - (> (file-modification-time (dboard:tabdat-dbfpath tabdat)) (dboard:tabdat-last-db-update tabdat))) - -(define (dashboard:set-db-update-time tabdat) - (dboard:tabdat-last-db-update-set! tabdat (file-modification-time (dboard:tabdat-dbfpath tabdat)))) - (define (dashboard:recalc modtime please-update-buttons last-db-update-time) (or please-update-buttons - (and (> (current-milliseconds)(+ *last-recalc-ended-time* 150)) - (> modtime last-db-update-time) + (and ;; (> (current-milliseconds)(+ *last-recalc-ended-time* 150)) ;; can't use this - it needs to be tab specific + (> modtime (- last-db-update-time 3)) ;; add three seconds of margin (> (current-seconds)(+ last-db-update-time 1))))) ;; (define *monitor-db-path* #f) (define *last-monitor-update-time* 0) ;; Force creation of the db in case it isn't already there. -(tasks:open-db) +;; (tasks:open-db) -(define (dashboard:get-youngest-run-db-mod-time tabdat) +(define (dashboard:get-youngest-run-db-mod-time dbdir) (handle-exceptions exn (begin - (debug:print 0 *default-log-port* "WARNING: error in accessing databases in get-youngest-run-db-mod-time: " ((condition-property-accessor 'exn 'message) exn)) + (debug:print 2 *default-log-port* "WARNING: error in accessing databases in get-youngest-run-db-mod-time: " + ((condition-property-accessor 'exn 'message) exn) " db-dir="dbdir ", exn=" exn) (current-seconds)) ;; something went wrong - just print an error and return current-seconds - (apply max (map (lambda (filen) - (file-modification-time filen)) - (glob (conc (dboard:tabdat-dbdir tabdat) "/*.db")))))) + (common:max (map (lambda (filen) + (file-modification-time filen)) + (glob (conc dbdir "/*.db*")))))) (define (dashboard:monitor-changed? commondat tabdat) (let* ((run-update-time (current-seconds)) (monitor-db-path (dboard:tabdat-monitor-db-path tabdat)) - (monitor-modtime (if (and monitor-db-path (file-exists? monitor-db-path)) + (monitor-modtime (if (and monitor-db-path (common:file-exists? monitor-db-path)) (file-modification-time monitor-db-path) -1))) (if (and (eq? (dboard:commondat-curr-tab-num commondat) 0) (or (> monitor-modtime *last-monitor-update-time*) (> (- run-update-time *last-monitor-update-time*) 5))) ;; update every 1/2 minute just in case @@ -2239,22 +3102,39 @@ (begin (set! *last-monitor-update-time* run-update-time) ;; monitor-modtime) #t) #f))) -(define (dashboard:database-changed? commondat tabdat) +(define (dboard:get-last-db-update tabdat context) + (hash-table-ref/default (dboard:tabdat-last-db-update tabdat) context 0)) + +(define (dboard:set-last-db-update! tabdat context newtime) + (hash-table-set! (dboard:tabdat-last-db-update tabdat) context newtime)) + +;; DOES NOT WORK RELIABLY WITH /tmp WAL mode files. Timestamps only change when the db +;; is closed (I think). If db dir starts with /tmp always return true +;; +(define (dashboard:database-changed? commondat tabdat #!key (context-key 'default)) (let* ((run-update-time (current-seconds)) - (modtime (dashboard:get-youngest-run-db-mod-time tabdat)) ;; NOTE: ensure this is tabdat!! - (recalc (dashboard:recalc modtime (dboard:commondat-please-update commondat) (dboard:tabdat-last-db-update tabdat)))) - (dboard:commondat-please-update-set! commondat #f) - recalc)) + (dbdir (dboard:tabdat-dbdir tabdat)) + (modtime (dashboard:get-youngest-run-db-mod-time dbdir)) + (recalc (dashboard:recalc modtime + (dboard:commondat-please-update commondat) + (dboard:get-last-db-update tabdat context-key)))) + ;; (dboard:tabdat-last-db-update tabdat)))) + (if recalc + (dboard:set-last-db-update! tabdat context-key run-update-time)) + (dboard:commondat-please-update-set! commondat #f) + recalc)) ;; point inside line ;; (define-inline (dashboard:px-between px lx1 lx2) (and (< lx1 px)(> lx2 px))) +;;Not reference anywhere +;; ;; can a bar be placed in row "rownum" covering x1 to x2 without overlapping with existing ;; bars? Use num-rows to check that a block will fit from rownum to (+ rownum num-rows) ;; (define (dashboard:row-collision rowhash rownum x1 x2 #!key (num-rows #f)) (let ((lastrow (if num-rows (+ rownum num-rows) rownum))) @@ -2285,20 +3165,10 @@ (cons (cons x1 x2) (hash-table-ref/default rowhash (+ i rownum) '()))) (if (< i num-rows) (loop (+ i 1))))) -;; get min or max, use > for max and < for min, this works around the limits on apply -;; -(define (dboard:min-max comp lst) - (if (null? lst) - #f ;; better than an exception for my needs - (fold (lambda (a b) - (if (comp a b) a b)) - (car lst) - lst))) - ;; sort a list of test-ids by the event _time using a hash table of id => testdat ;; (define-inline (dboard:sort-testsdat-by-event-time test-ids tests-ht) (sort test-ids (lambda (a b) @@ -2348,11 +3218,12 @@ (db:test-get-event_time (hash-table-ref testsdat (car b)))))))))) ;; run times tab data updater ;; (define (dashboard:run-times-tab-run-data-updater commondat tabdat tab-num) - (let* ((last-runs-update (dboard:tabdat-last-runs-update tabdat)) + (let* ((access-mode (dboard:tabdat-access-mode tabdat)) + (last-runs-update (dboard:tabdat-last-runs-update tabdat)) (runs-dat (rmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f last-runs-update)) (runs-header (vector-ref runs-dat 0)) ;; 0 is header, 1 is list of records (runs-hash (let ((ht (make-hash-table))) (for-each (lambda (run) (hash-table-set! ht (db:get-value-by-header run runs-header "id") run)) @@ -2378,18 +3249,18 @@ (let* ((run-record (hash-table-ref/default runs-hash run-id #f)) (key-vals (map (lambda (key)(db:get-value-by-header run-record runs-header key)) (dboard:tabdat-keys tabdat))) (run-name (db:get-value-by-header run-record runs-header "runname")) (col-name (conc (string-intersperse key-vals "\n") "\n" run-name)) - (run-path (append key-vals (list run-name))) - (existing (tree:find-node tb run-path))) + (run-path (append key-vals (list run-name)))) + ;; (existing (tree:find-node tb run-path))) (if (not (hash-table-ref/default (dboard:tabdat-path-run-ids tabdat) run-path #f)) (begin (hash-table-set! (dboard:tabdat-run-keys tabdat) run-id run-path) ;; Here we update the tests treebox and tree keys - (tree:add-node tb "Runs" run-path ;; (append key-vals (list run-name)) - userdata: (conc "run-id: " run-id)) + (tree:add-node tb "Runs" run-path) ;; (append key-vals (list run-name)) + ;; userdata: (conc "run-id: " run-id)) (hash-table-set! (dboard:tabdat-path-run-ids tabdat) run-path run-id) ;; (set! colnum (+ colnum 1)) )))) run-ids)) ;; (print "Updating rundat") @@ -2401,13 +3272,15 @@ (take (append (or (dboard:tabdat-target tabdat);; (string-split (dboard: "/") '("%" "%")) (make-list num-keys "%")) num-keys) )) - (runpatt (if (dboard:tabdat-target tabdat) - (last (dboard:tabdat-target tabdat)) - "%")) + (runpatt (if (and (dboard:tabdat-target tabdat) + (list? (dboard:tabdat-target tabdat)) + (not (null? (dboard:tabdat-target tabdat)))) + (last (dboard:tabdat-target tabdat)) + "%")) (testpatt (or (dboard:tabdat-test-patts tabdat) "%")) (filtrstr (conc targpatt "/" runpatt "/" testpatt))) ;; (print "targpatt: " targpatt " runpatt: " runpatt " testpatt: " testpatt) (if (not (equal? (dboard:tabdat-last-filter-str tabdat) filtrstr)) @@ -2515,11 +3388,11 @@ (apply vector tstart (cdr zeropt)) (hash-table-ref/default res-ht fieldname '()))))))) fields) res-ht) #f))))) - + ;; graph data ;; tsc=timescale, tfn=function; time->x ;; (define (dboard:graph commondat tabdat tabnum llx lly ulx uly tstart tend tsc tfn compname cmargin) (let* ((dwg (dboard:tabdat-drawing tabdat)) @@ -2527,11 +3400,15 @@ (cnv (dboard:tabdat-cnv tabdat)) (dur (- tstart tend)) ;; time duration (cmp (vg:get-component dwg "runslib" compname)) (cfg (configf:get-section *configdat* "graph")) (stdcolor (vg:rgb->number 120 130 140)) - (delta-y (- uly lly))) + (delta-y (- uly lly)) + (graph-matrix-table (dboard:tabdat-graph-matrix-table tabdat)) + (graph-cell-table (dboard:tabdat-graph-cell-table tabdat)) + (graph-matrix (dboard:tabdat-graph-matrix tabdat)) + (changed #f)) (vg:add-obj-to-comp cmp (vg:make-rect-obj llx lly ulx uly)) (vg:add-obj-to-comp cmp @@ -2556,68 +3433,98 @@ (lambda (cf) (let* ((alldat (dboard:graph-read-data (cadr cf) tstart tend))) (if alldat (for-each (lambda (fieldn) - (let* ((dat (hash-table-ref alldat fieldn)) - (vals (map (lambda (x)(vector-ref x 2)) dat))) - (if (not (null? vals)) - (let* ((maxval (apply max vals)) - (minval (min 0 (apply min vals))) - (yoff (- minval lly)) ;; minval)) - (deltaval (- maxval minval)) - (yscale (/ delta-y (if (zero? deltaval) 1 deltaval))) - (yfunc (lambda (y)(+ lly (* yscale (- y minval))))) ;; (lambda (y)(* (+ y yoff) yscale)))) - (graph-color (vg:generate-color))) - ;; (print (car cf) "; maxval: " maxval " minval: " minval " deltaval: " deltaval " yscale: " yscale) - (vg:add-obj-to-comp - cmp - (vg:make-text-obj (- llx 10)(yfunc maxval) (conc maxval))) - (vg:add-obj-to-comp - cmp - (vg:make-text-obj (- llx 10)(yfunc minval) (conc minval))) - (fold - (lambda (next prev) ;; #(time ? val) #(time ? val) - (if prev - (let* ((yval (vector-ref prev 2)) - (yval-next (vector-ref next 2)) - (last-tval (tfn (vector-ref prev 0))) - (last-yval (yfunc yval)) ;; (+ lly (* yscale (vector-ref prev 2)))) - (next-yval (yfunc yval-next)) - (curr-tval (tfn (vector-ref next 0)))) - (if (>= curr-tval last-tval) - (begin - (vg:add-obj-to-comp - cmp - ;;(vg:make-rect-obj last-tval lly curr-tval last-yval ;; (- stval 2) lly (+ stval 2)(+ lly (* yval yscale)) - (vg:make-line-obj last-tval last-yval curr-tval last-yval - line-color: graph-color)) - (vg:add-obj-to-comp - cmp - ;;(vg:make-rect-obj last-tval lly curr-tval last-yval ;; (- stval 2) lly (+ stval 2)(+ lly (* yval yscale)) - (vg:make-line-obj curr-tval last-yval curr-tval next-yval - line-color: graph-color))) - (print "ERROR: curr-tval is not > last-tval; curr-tval " curr-tval ", last-tval " last-tval)))) - next) - ;; for init create vector tstart,0 - #f ;; (vector tstart minval minval) - dat) - - ;; (for-each - ;; (lambda (dpt) - ;; (let* ((tval (vector-ref dpt 0)) - ;; (yval (vector-ref dpt 2)) - ;; (stval (tfn tval)) - ;; (syval (yfunc yval))) - ;; (vg:add-obj-to-comp - ;; cmp - ;; (vg:make-rect-obj (- stval 2) lly (+ stval 2)(+ lly (* yval yscale)) - ;; fill-color: stdcolor)))) - ;; dat) - )))) ;; for each data point in the series + (let*-values (((dat) (hash-table-ref alldat fieldn)) + ((vals minval maxval) (if (null? dat) + (values '() #f #f) + (let loop ((hed (car dat)) + (tal (cdr dat)) + (res '()) + (min (vector-ref (car dat) 2)) + (max (vector-ref (car dat) 2))) + (let* ((val (vector-ref hed 2)) + (newmin (if (< val min) val min)) + (newmax (if (> val max) val max)) + (newres (cons val res))) + (if (null? tal) + (values (reverse res) (- newmin 2) (+ newmax 2)) + (loop (car tal)(cdr tal) newres newmin newmax))))))) + (if (not (hash-table-exists? graph-matrix-table fieldn)) + (begin + (let* ((graph-color-rgb (vg:generate-color-rgb)) + (graph-color (vg:iup-color->number graph-color-rgb)) + (graph-matrix-col (dboard:tabdat-graph-matrix-col tabdat)) + (graph-matrix-row (dboard:tabdat-graph-matrix-row tabdat)) + (graph-cell (conc graph-matrix-row ":" graph-matrix-col)) + (graph-dat (make-dboard:graph-dat + id: fieldn + color: graph-color + flag: #t + cell: graph-cell + ))) + (hash-table-set! graph-matrix-table fieldn graph-dat) + (hash-table-set! graph-cell-table graph-cell graph-dat) + ;; (print "Graph data " graph-matrix-row " " graph-matrix-col " " fieldn " " graph-color " " graph-color-rgb " ") + ;; (print "Graph data " graph-matrix-row " " graph-matrix-col " " fieldn " " graph-color " " graph-color-rgb " ") + (set! changed #t) + (iup:attribute-set! graph-matrix (conc graph-matrix-row ":" graph-matrix-col) fieldn) + (iup:attribute-set! graph-matrix (conc "BGCOLOR" (conc graph-matrix-row ":" graph-matrix-col)) graph-color-rgb) + (if (> graph-matrix-col 10) + (begin + (dboard:tabdat-graph-matrix-col-set! tabdat 1) + (dboard:tabdat-graph-matrix-row-set! tabdat (+ graph-matrix-row 1))) + (dboard:tabdat-graph-matrix-col-set! tabdat (+ graph-matrix-col 1))) + ))) + (if (not (null? vals)) + (let* (;; (maxval (apply max vals)) + ;; (minval (min 0 (apply min vals))) + (yoff (- minval lly)) ;; minval)) + (deltaval (- maxval minval)) + (yscale (/ delta-y (if (zero? deltaval) 1 deltaval))) + (yfunc (lambda (y)(+ lly (* yscale (- y minval))))) ;; (lambda (y)(* (+ y yoff) yscale)))) + (graph-dat (hash-table-ref graph-matrix-table fieldn)) + (graph-color (dboard:graph-dat-color graph-dat)) + (graph-flag (dboard:graph-dat-flag graph-dat))) + (if graph-flag + (begin + (vg:add-obj-to-comp + cmp + (vg:make-text-obj (- llx 10)(yfunc maxval) (conc maxval))) + (vg:add-obj-to-comp + cmp + (vg:make-text-obj (- llx 10)(yfunc minval) (conc minval))) + (fold + (lambda (next prev) ;; #(time ? val) #(time ? val) + (if prev + (let* ((yval (vector-ref prev 2)) + (yval-next (vector-ref next 2)) + (last-tval (tfn (vector-ref prev 0))) + (last-yval (yfunc yval)) ;; (+ lly (* yscale (vector-ref prev 2)))) + (next-yval (yfunc yval-next)) + (curr-tval (tfn (vector-ref next 0)))) + (if (>= curr-tval last-tval) + (begin + (vg:add-obj-to-comp + cmp + ;;(vg:make-rect-obj last-tval lly curr-tval last-yval ;; (- stval 2) lly (+ stval 2)(+ lly (* yval yscale)) + (vg:make-line-obj last-tval last-yval curr-tval last-yval + line-color: graph-color)) + (vg:add-obj-to-comp + cmp + ;;(vg:make-rect-obj last-tval lly curr-tval last-yval ;; (- stval 2) lly (+ stval 2)(+ lly (* yval yscale)) + (vg:make-line-obj curr-tval last-yval curr-tval next-yval + line-color: graph-color))) + (print "ERROR: curr-tval is not > last-tval; curr-tval " curr-tval ", last-tval " last-tval)))) + next) + #f ;; (vector tstart minval minval) + dat) + )))))) ;; for each data point in the series (hash-table-keys alldat))))) - cfg))) + cfg) + (if changed (iup:attribute-set! graph-matrix "REDRAW" "ALL")))) ;; run times tab ;; (define (dashboard:run-times-tab-layout-updater commondat tabdat tab-num) ;; each test is an object in the run component @@ -2637,11 +3544,12 @@ (compact-layout (dboard:tabdat-compact-layout tabdat)) (row-height (if compact-layout 2 10)) (graph-height 120) (run-to-run-margin 25)) (dboard:tabdat-layout-update-ok-set! tabdat #t) - (if (canvas? cnv) + (if (and (canvas? cnv) + (not (null? allruns))) ;; allruns can go null when browsing the runs tree (let*-values (((sizex sizey sizexmm sizeymm) (canvas-size cnv)) ((originx originy) (canvas-origin cnv)) ((calc-y) (lambda (rownum) (- (/ sizey 2) (* rownum row-height)))) @@ -2682,12 +3590,12 @@ (all-tids (hash-table-keys tests-ht)) ;; (apply append hierdat)) ;; was testsdat (testsdat (hash-table-values tests-ht)) (runcomp (vg:comp-new));; new component for this run (rows-used (make-hash-table)) ;; keep track of what parts of the rows are used here row1 = (obj1 obj2 ...) ;; (row-height 4) - (run-start (dboard:min-max < (map db:test-get-event_time testsdat))) - (run-end (let ((re (dboard:min-max > (map (lambda (t)(+ (db:test-get-event_time t)(db:test-get-run_duration t))) testsdat)))) + (run-start (common:min-max < (map db:test-get-event_time testsdat))) + (run-end (let ((re (common:min-max > (map (lambda (t)(+ (db:test-get-event_time t)(db:test-get-run_duration t))) testsdat)))) (max re (+ 1 run-start)))) ;; use run-start+1 if run-start == run-end so delta is not zero (timeoffset (- run-start)) ;; (+ fixed-originx canvas-margin) run-start)) (run-duration (- run-end run-start)) (timescale (/ (- sizex (* 2 canvas-margin)) (if (> run-duration 0) @@ -2842,125 +3750,125 @@ (runloop (car runtal)(cdr runtal) (+ run-num 1) newdoneruns) (escapeloop #t) ;; (dboard:tabdat-layout-update-ok tabdat) ))))))))) ;; new-run-start-row ))) (debug:print 2 *default-log-port* "no tabdat for run-times-tab-updater")))) + +;; handy trick for printing a record +;; +;; (pp (dboard:tabdat->alist tabdat)) +;; +;; removing the tabdat-values proc +;; +;; (define (tabdat-values tabdat) + +;; runs update-rundat using the various filters from the gui +;; +(define (dashboard:do-update-rundat tabdat) + (dboard:update-rundat + tabdat + (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "runname" "%") + (dboard:tabdat-numruns tabdat) + (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "test-name" "%/%") + ;; generate key patterns from the target stored in tabdat + (let* ((dbkeys (dboard:tabdat-dbkeys tabdat))) + (let ((fres (if (dboard:tabdat-target tabdat) + (let ((ptparts (append (dboard:tabdat-target tabdat)(make-list (length dbkeys) "%")))) + (map (lambda (k v)(list k v)) dbkeys ptparts)) + (let ((res '())) + (for-each (lambda (key) + (if (not (equal? key "runname")) + (let ((val (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) key #f))) + (if val (set! res (cons (list key val) res)))))) + dbkeys) + res)))) + fres)))) (define (dashboard:runs-tab-updater commondat tab-num) (debug:catch-and-dump (lambda () (let* ((tabdat (dboard:common-get-tabdat commondat tab-num: tab-num)) (dbkeys (dboard:tabdat-dbkeys tabdat))) - (update-rundat tabdat - (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "runname" "%") - (dboard:tabdat-numruns tabdat) - (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "test-name" "%/%") - ;; (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "item-name" "%") - (let* ((dbkeys (dboard:tabdat-dbkeys tabdat))) - ;; (print "dbkeys: " dbkeys) - (let ((fres (if (dboard:tabdat-target tabdat) - (let ((ptparts (append (dboard:tabdat-target tabdat)(make-list (length dbkeys) "%")))) - (map (lambda (k v)(list k v)) dbkeys ptparts)) - (let ((res '())) - ;; (print "target: " (dboard:tabdat-target tabdat)) - (for-each (lambda (key) - (if (not (equal? key "runname")) - (let ((val (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) key #f))) - (if val (set! res (cons (list key val) res)))))) - dbkeys) - res)))) - ;; (debug:print 0 *default-log-port* "fres: " fres) - fres))) + (dashboard:do-update-rundat tabdat) (let ((uidat (dboard:commondat-uidat commondat))) (update-buttons tabdat uidat (dboard:tabdat-numruns tabdat) (dboard:tabdat-num-tests tabdat))) )) "dashboard:runs-tab-updater")) -;; ((2) -;; (dashboard:update-run-summary-tab)) -;; ((3) -;; (dashboard:update-new-view-tab)) -;; (else -;; (dboard:common-run-curr-updater commondat))) -;; (set! *last-recalc-ended-time* (current-milliseconds)))))))) - ;;====================================================================== ;; The heavy lifting starts here ;;====================================================================== -;; ease debugging by loading ~/.dashboardrc -(let ((debugcontrolf (conc (get-environment-variable "HOME") "/.dashboardrc"))) - (if (file-exists? debugcontrolf) - (load debugcontrolf))) - (define (main) - (if (not (args:get-arg "-skip-version-check"))(common:exit-on-version-changed)) - (let* ((commondat (dboard:commondat-make))) - ;; Move this stuff to db.scm? I'm not sure that is the right thing to do... - (cond - ((args:get-arg "-test") ;; run-id,test-id - (let* ((dat (let ((d (map string->number (string-split (args:get-arg "-test") ",")))) - (if (> (length d) 1) - d - (list #f #f)))) - (run-id (car dat)) - (test-id (cadr dat))) - (if (and (number? run-id) - (number? test-id) - (>= test-id 0)) - (examine-test run-id test-id) - (begin - (debug:print 3 *default-log-port* "INFO: tried to open test with invalid run-id,test-id. " (args:get-arg "-test")) - (exit 1))))) - ;; ((args:get-arg "-guimonitor") - ;; (gui-monitor (dboard:tabdat-dblocal tabdat))) - (else - (dboard:commondat-uidat-set! commondat (make-dashboard-buttons commondat)) ;; (dboard:tabdat-dblocal data) - ;; (dboard:tabdat-numruns tabdat) - ;; (dboard:tabdat-num-tests tabdat) - ;; (dboard:tabdat-dbkeys tabdat) - ;; runs-sum-dat new-view-dat)) - ;; legacy setup of updaters for summary tab and runs tab - ;; summary tab - ;; (dboard:commondat-add-updater - ;; commondat - ;; (lambda () - ;; (dashboard:summary-tab-updater commondat 0)) - ;; tab-num: 0) - ;; runs tab - (dboard:commondat-curr-tab-num-set! commondat 0) - (dboard:commondat-add-updater - commondat - (lambda () - (dashboard:runs-tab-updater commondat 1)) - tab-num: 1) - (iup:callback-set! *tim* - "ACTION_CB" - (lambda (time-obj) - (let ((update-is-running #f)) + (let ((mtdb-path (conc *toppath* "/megatest.db"))) ;; + (if (and (common:file-exists? mtdb-path) + (file-write-access? mtdb-path)) + (if (not (args:get-arg "-skip-version-check")) + (common:exit-on-version-changed))) + (let* ((commondat (dboard:commondat-make))) + ;; Move this stuff to db.scm? I'm not sure that is the right thing to do... + (cond + ((args:get-arg "-test") ;; run-id,test-id + (let* ((dat (let ((d (map string->number (string-split (args:get-arg "-test") ",")))) + (if (> (length d) 1) + d + (list #f #f)))) + (run-id (car dat)) + (test-id (cadr dat))) + (if (and (number? run-id) + (number? test-id) + (>= test-id 0)) + (dashboard-tests:examine-test run-id test-id) + (begin + (debug:print 3 *default-log-port* "INFO: tried to open test with invalid run-id,test-id. " (args:get-arg "-test")) + (exit 1))))) + ;; ((args:get-arg "-guimonitor") + ;; (gui-monitor (dboard:tabdat-dblocal tabdat))) + (else + (dboard:commondat-uidat-set! commondat (make-dashboard-buttons commondat)) + (dboard:commondat-curr-tab-num-set! commondat 0) + (dboard:commondat-add-updater + commondat + (lambda () + (dashboard:runs-tab-updater commondat 1)) + tab-num: 1) + ;; may not want this alive (manually merged it from v1.66) + (dboard:commondat-add-updater + commondat + (lambda () + (dashboard:runs-tab-updater commondat 1)) + tab-num: 2) + (iup:callback-set! *tim* + "ACTION_CB" + (lambda (time-obj) + (let ((update-is-running #f)) (mutex-lock! (dboard:commondat-update-mutex commondat)) (set! update-is-running (dboard:commondat-updating commondat)) (if (not update-is-running) - (dboard:commondat-updating-set! commondat #t)) + (dboard:commondat-updating-set! commondat #t)) (mutex-unlock! (dboard:commondat-update-mutex commondat)) (if (not update-is-running) ;; we know that the update was not running and we now have a lock on doing an update - (begin - (dboard:common-run-curr-updaters commondat) ;; (dashboard:run-update commondat) - (mutex-lock! (dboard:commondat-update-mutex commondat)) - (dboard:commondat-updating-set! commondat #f) - (mutex-unlock! (dboard:commondat-update-mutex commondat))) - )) - 1)))) - - (let ((th1 (make-thread (lambda () - (thread-sleep! 1) - (dboard:common-run-curr-updaters commondat 0) ;; force update of summary tab - ;; (dboard:commondat-please-update-set! commondat #t) ;; MRW: ww36.3 - why was please update set true here? Removing it for now. - ;; (dashboard:run-update commondat) - ) "update buttons once")) - (th2 (make-thread iup:main-loop "Main loop"))) - ;; (thread-start! th1) - (thread-start! th2) - (thread-join! th2)))) - -(main) + (begin + (dboard:common-run-curr-updaters commondat) ;; (dashboard:run-update commondat) + (mutex-lock! (dboard:commondat-update-mutex commondat)) + (dboard:commondat-updating-set! commondat #f) + (mutex-unlock! (dboard:commondat-update-mutex commondat))) + )) + 1)))) + + (let ((th1 (make-thread (lambda () + (thread-sleep! 1) + (dboard:common-run-curr-updaters commondat 0) ;; force update of summary tab + ) "update buttons once")) + (th2 (make-thread iup:main-loop "Main loop"))) + (thread-start! th2) + (thread-join! th2))))) + +;; ease debugging by loading ~/.dashboardrc +(let ((debugcontrolf (conc (get-environment-variable "HOME") "/.dashboardrc"))) + (if (common:file-exists? debugcontrolf) + (load debugcontrolf))) + +(if (args:get-arg "-repl") + (repl) + (main)) Index: datashare-testing/.sd.config ================================================================== --- datashare-testing/.sd.config +++ datashare-testing/.sd.config @@ -1,5 +1,22 @@ +# Copyright 2006-2017, Matthew Welland. +# +# This file is part of Megatest. +# +# Megatest is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# Megatest is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with Megatest. If not, see . +# # Read in the users vars first (so the offical data cannot be overridden [include ~/.datashare.config] # Read in local overrides [include datashare.config] Index: datashare-testing/.spublish.config ================================================================== --- datashare-testing/.spublish.config +++ datashare-testing/.spublish.config @@ -1,5 +1,22 @@ +# Copyright 2006-2017, Matthew Welland. +# +# This file is part of Megatest. +# +# Megatest is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# Megatest is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with Megatest. If not, see . +# [settings] target-dir #{scheme (create-directory "/tmp/#{getenv USER}/target" #t)} allowed-users matt mrwellan pjhatwal allowed-chars [0-9a-zA-Z\-\.]+ admins matt Index: datashare-testing/.sretrieve.config ================================================================== --- datashare-testing/.sretrieve.config +++ datashare-testing/.sretrieve.config @@ -1,8 +1,25 @@ +# Copyright 2006-2017, Matthew Welland. +# +# This file is part of Megatest. +# +# Megatest is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# Megatest is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with Megatest. If not, see . +# [settings] base-dir /tmp/delme_data -allowed-users matt +allowed-users matt allowed-chars [0-9a-zA-Z\-\.]+ allowed-sub-paths [0-9a-zA-Z\-\.]+ [database] location #{scheme (create-directory "/tmp/#{getenv USER}" #t)} Index: datashare-testing/NOTES ================================================================== --- datashare-testing/NOTES +++ datashare-testing/NOTES @@ -1,3 +1,20 @@ +# Copyright 2006-2017, Matthew Welland. +# +# This file is part of Megatest. +# +# Megatest is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# Megatest is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with Megatest. If not, see . + To test sretrieve first publish megatest as v1.60 at least twice to get iterations 0 and 1 Index: datashare-testing/megatest.config ================================================================== --- datashare-testing/megatest.config +++ datashare-testing/megatest.config @@ -1,4 +1,21 @@ +# Copyright 2006-2017, Matthew Welland. +# +# This file is part of Megatest. +# +# Megatest is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# Megatest is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with Megatest. If not, see . +# [v1.60] status released iteration 1 Index: datashare-testing/packages.config ================================================================== --- datashare-testing/packages.config +++ datashare-testing/packages.config @@ -1,4 +1,21 @@ +# Copyright 2006-2017, Matthew Welland. +# +# This file is part of Megatest. +# +# Megatest is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# Megatest is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with Megatest. If not, see . +# [v1.60] status released iteration 1 Index: datashare.scm ================================================================== --- datashare.scm +++ datashare.scm @@ -1,14 +1,22 @@ ;; Copyright 2006-2013, Matthew Welland. ;; -;; This program is made available under the GNU GPL version 2.0 or -;; greater. See the accompanying file COPYING for details. +;; This file is part of Megatest. +;; +;; Megatest is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. +;; +;; Megatest is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. ;; -;; This program is distributed WITHOUT ANY WARRANTY; without even the -;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR -;; PURPOSE. +;; You should have received a copy of the GNU General Public License +;; along with Megatest. If not, see . (use ssax) (use sxml-serializer) (use sxml-modifications) (use regex) @@ -226,11 +234,11 @@ (if (and path (directory? path) (file-read-access? path)) (let* ((dbpath (conc path "/datashare.db")) (writeable (file-write-access? dbpath)) - (dbexists (file-exists? dbpath)) + (dbexists (common:file-exists? dbpath)) (handler (make-busy-timeout 136000))) (handle-exceptions exn (begin (debug:print 2 *default-log-port* "ERROR: problem accessing db " dbpath @@ -413,11 +421,11 @@ paths)) ;; remove existing link and if possible ... ;; create path to next of tip of target, create link back to source (define (datashare:build-dir-make-link source target) - (if (file-exists? target)(datashare:backup-move target)) + (if (common:file-exists? target)(datashare:backup-move target)) (create-directory (pathname-directory target) #t) (create-symbolic-link source target)) (define (datashare:backup-move path) (let* ((trashdir (conc (pathname-directory path) "/.trash")) @@ -518,11 +526,11 @@ (define (datashare:path->lst path) (string-split path "/")) (define (datashare:pathdat-apply-heuristics configdat path) (cond - ((file-exists? path) "found") + ((common:file-exists? path) "found") (else (conc path " not installed")))) (define (datashare:get-view configdat) (iup:vbox (iup:hbox @@ -692,11 +700,11 @@ (define (datashare:find name paths) (if (null? paths) #f (let loop ((hed (car paths)) (tal (cdr paths))) - (if (file-exists? (conc hed "/" name)) + (if (common:file-exists? (conc hed "/" name)) hed (if (null? tal) #f (loop (car tal)(cdr tal))))))) @@ -706,11 +714,11 @@ (define (datashare:load-config exe-dir exe-name) (let* ((fname (conc exe-dir "/." exe-name ".config"))) (ini:property-separator-patt " * *") (ini:property-separator #\space) - (if (file-exists? fname) + (if (common:file-exists? fname) ;; (ini:read-ini fname) (read-config fname #f #t) (make-hash-table)))) (define (datashare:process-action configdat action . args) @@ -785,11 +793,11 @@ versions) (sqlite3:finalize! db))))) ;; ease debugging by loading ~/.dashboardrc - REMOVE FROM PRODUCTION! (let ((debugcontrolf (conc (get-environment-variable "HOME") "/.datasharerc"))) - (if (file-exists? debugcontrolf) + (if (common:file-exists? debugcontrolf) (load debugcontrolf))) (define (main) (let* ((args (argv)) (prog (car args)) Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -1,22 +1,33 @@ ;;====================================================================== -;; Copyright 2006-2013, Matthew Welland. -;; -;; This program is made available under the GNU GPL version 2.0 or -;; greater. See the accompanying file COPYING for details. -;; -;; This program is distributed WITHOUT ANY WARRANTY; without even the -;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR -;; PURPOSE. +;; Copyright 2006-2016, Matthew Welland. +;; +;; This file is part of Megatest. +;; +;; Megatest is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. +;; +;; Megatest is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with Megatest. If not, see . +;; ;;====================================================================== ;;====================================================================== ;; Database access ;;====================================================================== -(require-extension (srfi 18) extras tcp) -(use sqlite3 srfi-1 posix regex regex-case srfi-69 csv-xml s11n md5 message-digest base64 format dot-locking z3) +;; dbstruct vector containing all the relevant dbs like main.db, megatest.db, run.db etc + +(use (srfi 18) extras tcp stack) +(use sqlite3 srfi-1 posix regex regex-case srfi-69 csv-xml s11n md5 message-digest base64 format dot-locking z3 typed-records matchable) (import (prefix sqlite3 sqlite3:)) (import (prefix base64 base64:)) (declare (unit db)) (declare (uses common)) @@ -28,35 +39,95 @@ (include "common_records.scm") (include "db_records.scm") (include "key_records.scm") (include "run_records.scm") -(define *rundb-mutex* (make-mutex)) ;; prevent problems opening/closing rundb's (define *number-of-writes* 0) (define *number-non-write-queries* 0) + +;;====================================================================== +;; R E C O R D S +;;====================================================================== + +;; each db entry is a pair ( db . dbfilepath ) +;; I propose this record evolves into the area record +;; +(defstruct dbr:dbstruct + (tmpdb #f) + (dbstack #f) ;; stack for tmp db handles, do not initialize with a stack + (mtdb #f) + (refndb #f) + (homehost #f) ;; not used yet + (on-homehost #f) ;; not used yet + (read-only #f) + (stmt-cache (make-hash-table)) + ) ;; goal is to converge on one struct for an area but for now it is too confusing + + +;; record for keeping state,status and count for doing roll-ups in +;; iterated tests +;; +(defstruct dbr:counts + (state #f) + (status #f) + (count 0)) + +;;====================================================================== +;; alist-of-alists +;;====================================================================== +;; +;; (define (db:aa-set! dat key1 key2 val) +;; (let loop (( + +;;====================================================================== +;; hash of hashs +;;====================================================================== + + +(define (db:hoh-set! dat key1 key2 val) + (let* ((subhash (hash-table-ref/default dat key1 #f))) + (if subhash + (hash-table-set! subhash key2 val) + (begin + (hash-table-set! dat key1 (make-hash-table)) + (db:hoh-set! dat key1 key2 val))))) + +(define (db:hoh-get dat key1 key2) + (let* ((subhash (hash-table-ref/default dat key1 #f))) + (and subhash + (hash-table-ref/default subhash key2 #f)))) + +(define (db:get-cache-stmth dbstruct db stmt) + (let* ((stmt-cache (dbr:dbstruct-stmt-cache dbstruct)) + (stmth (db:hoh-get stmt-cache db stmt))) + (or stmth + (let* ((newstmth (sqlite3:prepare db stmt))) + (db:hoh-set! stmt-cache db stmt newstmth) + newstmth)))) ;;====================================================================== ;; SQLITE3 HELPERS ;;====================================================================== (define (db:general-sqlite-error-dump exn stmt . params) - (let ((err-status ((condition-property-accessor 'sqlite3 'status #f) exn))) + (let ((err-status ((condition-property-accessor 'sqlite3 'status #f) exn))) ;; RADT ... how does this work? ;; check for (exn sqlite3) ((condition-property-accessor 'exn 'message) exn) (print "err-status: " err-status) (debug:print-error 0 *default-log-port* " query " stmt " failed, params: " params ", error: " ((condition-property-accessor 'exn 'message) exn)) (print-call-chain (current-error-port)))) -;; convert to -inline +;; convert to -inline +;; (define (db:first-result-default db stmt default . params) (handle-exceptions exn (let ((err-status ((condition-property-accessor 'sqlite3 'status #f) exn))) ;; check for (exn sqlite3) ((condition-property-accessor 'exn 'message) exn) (if (eq? err-status 'done) default (begin - (debug:print-error 0 *default-log-port* " query " stmt " failed, params: " params ", error: " ((condition-property-accessor 'exn 'message) exn)) + (debug:print-error 0 *default-log-port* " query " stmt " failed, params: " params ", error: " ((condition-property-accessor 'exn 'message) exn) ", exn=" exn) (print-call-chain (current-error-port)) default))) (apply sqlite3:first-result db stmt params))) ;; Get/open a database @@ -64,21 +135,20 @@ ;; if #f => get main db ;; if db already open - return inmem ;; if db not open, open inmem, rundb and sync then return inmem ;; inuse gets set automatically for rundb's ;; -(define (db:get-db dbstruct run-id) - (if (sqlite3:database? dbstruct) ;; pass sqlite3 databases on through - dbstruct - (begin - (let ((dbdat (if (or (not run-id) - (eq? run-id 0)) - (db:open-main dbstruct) - (db:open-rundb dbstruct run-id) - ))) - dbdat)))) - +(define (db:get-db dbstruct) ;; run-id) + (if (stack? (dbr:dbstruct-dbstack dbstruct)) + (if (stack-empty? (dbr:dbstruct-dbstack dbstruct)) + (let ((newdb (db:open-megatest-db path: (db:dbfile-path)))) + ;; (stack-push! (dbr:dbstruct-dbstack dbstruct) newdb) + newdb) + (stack-pop! (dbr:dbstruct-dbstack dbstruct))) + (db:open-db dbstruct))) + +;; ;; legacy handling of structure for managing db's. Refactor this into dbr:? (define (db:dbdat-get-db dbdat) (if (pair? dbdat) (car dbdat) dbdat)) @@ -85,42 +155,57 @@ (define (db:dbdat-get-path dbdat) (if (pair? dbdat) (cdr dbdat) #f)) -;; mod-read: -;; 'mod modified data -;; 'read read data -;; -(define (db:done-with dbstruct run-id mod-read) - (if (not (sqlite3:database? dbstruct)) - (begin - (mutex-lock! *rundb-mutex*) - (if (eq? mod-read 'mod) - (dbr:dbstruct-set-mtime! dbstruct (current-milliseconds)) - (dbr:dbstruct-set-rtime! dbstruct (current-milliseconds))) - (dbr:dbstruct-set-inuse! dbstruct #f) - (mutex-unlock! *rundb-mutex*)))) - -;; (db:with-db dbstruct run-id sqlite3:exec "select blah from blaz;") +(define-inline (db:generic-error-printout exn . message) + (print-call-chain (current-error-port)) + (apply debug:print-error 0 *default-log-port* message) + (debug:print-error 0 *default-log-port* " params: " params + ", error: " ((condition-property-accessor 'exn 'message) exn) + ", arguments: " ((condition-property-accessor 'exn 'arguments) exn) + ", location: " ((condition-property-accessor 'exn 'location) exn) + )) + +;; (db:with-db dbstruct run-id sqlite3:exec "select blah fgrom blaz;") ;; r/w is a flag to indicate if the db is modified by this query #t = yes, #f = no ;; (define (db:with-db dbstruct run-id r/w proc . params) - (let* ((dbdat (if (vector? dbstruct) - (db:get-db dbstruct run-id) - dbstruct)) ;; cheat, allow for passing in a dbdat - (db (db:dbdat-get-db dbdat))) - (db:delay-if-busy dbdat) - (handle-exceptions - exn + (let* ((have-struct (dbr:dbstruct? dbstruct)) + (dbdat (if have-struct + (db:get-db dbstruct) + #f)) + (db (if have-struct + (db:dbdat-get-db dbdat) + dbstruct)) + (fname (db:dbdat-get-path dbdat)) + (use-mutex (> *api-process-request-count* 25))) ;; was 25 + (if (and use-mutex + (common:low-noise-print 120 "over-50-parallel-api-requests")) + (debug:print-info 0 *default-log-port* *api-process-request-count* " parallel api requests being processed in process " (current-process-id) ", throttling access")) + (if (common:low-noise-print 600 (conc "parallel-api-requests" *max-api-process-requests*)) + (debug:print-info 2 *default-log-port* "Parallel api request count: " *api-process-request-count* " max parallel requests: " *max-api-process-requests*)) + (condition-case (begin - (debug:print-error 0 *default-log-port* "sqlite3 issue in db:with-db, dbstruct=" dbstruct ", run-id=" run-id ", proc=" proc ", params=" params " error: " ((condition-property-accessor 'exn 'message) exn)) - (print-call-chain (current-error-port))) - (let ((res (apply proc db params))) - (if (vector? dbstruct)(db:done-with dbstruct run-id r/w)) - res)))) - + (if use-mutex (mutex-lock! *db-with-db-mutex*)) + (let ((res (apply proc db params))) + (if use-mutex (mutex-unlock! *db-with-db-mutex*)) + ;; (if (vector? dbstruct)(db:done-with dbstruct run-id r/w)) + (if dbdat (stack-push! (dbr:dbstruct-dbstack dbstruct) dbdat)) + res)) + (exn (io-error) + (db:generic-error-printout exn "ERROR: i/o error with " fname ". Check permissions, disk space etc. and try again.")) + (exn (corrupt) + (db:generic-error-printout exn "ERROR: database " fname " is corrupt. Repair it to proceed.")) + (exn (busy) + (db:generic-error-printout exn "ERROR: database " fname + " is locked. Try copying to another location, remove original and copy back.")) + (exn (permission)(db:generic-error-printout exn "ERROR: database " fname " has some permissions problem.")) + (exn () + (db:generic-error-printout exn "ERROR: Unknown error with database " fname " message: " + ((condition-property-accessor 'exn 'message) exn)))))) + ;;====================================================================== ;; K E E P F I L E D B I N dbstruct ;;====================================================================== ;; (define (db:get-filedb dbstruct run-id) @@ -143,261 +228,279 @@ ;; (let ((fdb (db:get-filedb dbstruct))) ;; (filedb:get-path db id))) ;; NB// #f => return dbdir only ;; (was planned to be; zeroth db with name=main.db) +;; +;; If run-id is #f return to create and retrieve the path where the db will live. ;; -(define (db:dbfile-path run-id) - (let* ((dbdir (db:get-dbdir)) - (fname (if run-id - (if (eq? run-id 0) "main.db" (conc run-id ".db")) - #f))) - (handle-exceptions - exn - (begin - (debug:print-error 0 *default-log-port* "Couldn't create path to " dbdir) - (exit 1)) - (if (not (directory? dbdir))(create-directory dbdir #t))) - (if fname - (conc dbdir "/" fname) - dbdir))) - -(define (db:get-dbdir) - (or (configf:lookup *configdat* "setup" "dbdir") - (conc (configf:lookup *configdat* "setup" "linktree") "/.db"))) - +(define db:dbfile-path common:get-db-tmp-area) + (define (db:set-sync db) (let ((syncprag (configf:lookup *configdat* "setup" "sychronous"))) - (sqlite3:execute db (conc "PRAGMA synchronous = " (or syncprag 1) ";")))) + (sqlite3:execute db (conc "PRAGMA synchronous = " (or syncprag 0) ";")))) ;; open an sql database inside a file lock -;; ;; returns: db existed-prior-to-opening +;; RA => Returns a db handler; sets the lock if opened in writable mode ;; +;; (define *db-open-mutex* (make-mutex)) + (define (db:lock-create-open fname initproc) - ;; (if (file-exists? fname) - ;; (let ((db (sqlite3:open-database fname))) - ;; (sqlite3:set-busy-handler! db (make-busy-timeout 136000)) - ;; (db:set-sync db) ;; (sqlite3:execute db "PRAGMA synchronous = 0;") - ;; db) - (let* ((parent-dir (pathname-directory fname)) + (let* ((parent-dir (or (pathname-directory fname)(current-directory))) ;; no parent? go local + (raw-fname (pathname-file fname)) (dir-writable (file-write-access? parent-dir)) - (file-exists (file-exists? fname)) + (file-exists (common:file-exists? fname)) (file-write (if file-exists (file-write-access? fname) dir-writable ))) + ;; (mutex-lock! *db-open-mutex*) ;; tried this mutex, not clear it helped. (if file-write ;; dir-writable - (let (;; (lock (obtain-dot-lock fname 1 5 10)) - (db (sqlite3:open-database fname))) - (sqlite3:set-busy-handler! db (make-busy-timeout 136000)) - (db:set-sync db) ;; (sqlite3:execute db "PRAGMA synchronous = 0;") - (if (not file-exists)(initproc db)) - ;; (release-dot-lock fname) - db) - (begin - (debug:print 2 *default-log-port* "WARNING: opening db in non-writable dir " fname) - (sqlite3:open-database fname))))) ;; ) - -;; This routine creates the db. It is only called if the db is not already opened -;; -(define (db:open-rundb dbstruct run-id #!key (attemptnum 0)(do-not-open #f)) ;; (conc *toppath* "/megatest.db") (car *configinfo*))) - (let* ((local (dbr:dbstruct-get-local dbstruct)) - (rdb (if local - (dbr:dbstruct-get-localdb dbstruct run-id) - (dbr:dbstruct-get-inmem dbstruct)))) ;; (dbr:dbstruct-get-runrec dbstruct run-id 'inmem))) - (if (or rdb - do-not-open) - rdb - (begin - (mutex-lock! *rundb-mutex*) - (let* ((dbpath (db:dbfile-path run-id)) ;; (conc toppath "/db/" run-id ".db")) - (dbexists (file-exists? dbpath)) - (inmem (if local #f (db:open-inmem-db))) - (refdb (if local #f (db:open-inmem-db))) - (db (db:lock-create-open dbpath ;; this is the database physically on disk - (lambda (db) - (handle-exceptions - exn - (begin - ;; (release-dot-lock dbpath) - (if (> attemptnum 2) - (debug:print-error 0 *default-log-port* "tried twice, cannot create/initialize db for run-id " run-id ", at path " dbpath) - (db:open-rundb dbstruct run-id attemptnum (+ attemptnum 1)))) - (db:initialize-run-id-db db) - (sqlite3:execute - db - "INSERT OR IGNORE INTO tests (id,run_id,testname,event_time,item_path,state,status) VALUES (?,?,'bogustest',strftime('%s','now'),'nowherepath','DELETED','n/a');" - (* run-id 30000) ;; allow for up to 30k tests per run - run-id) - ;; do a dummy query to test that the table exists and the db is truly readable - (sqlite3:execute db "SELECT * FROM tests WHERE id=?;" (* run-id 30000)) - )))) ;; add strings db to rundb, not in use yet - ;; )) ;; (sqlite3:open-database dbpath)) - (olddb (if *megatest-db* - *megatest-db* - (let ((db (db:open-megatest-db))) - (set! *megatest-db* db) - db))) - (write-access (file-write-access? dbpath)) - ;; (handler (make-busy-timeout 136000)) - ) - (if (and dbexists (not write-access)) - (set! *db-write-access* #f)) ;; only unset so other db's also can use this control - (dbr:dbstruct-set-rundb! dbstruct (cons db dbpath)) - (dbr:dbstruct-set-inuse! dbstruct #t) - (dbr:dbstruct-set-olddb! dbstruct olddb) - ;; (dbr:dbstruct-set-run-id! dbstruct run-id) - (mutex-unlock! *rundb-mutex*) - (if local - (begin - (dbr:dbstruct-set-localdb! dbstruct run-id db) ;; (dbr:dbstruct-set-inmem! dbstruct db) ;; direct access ... - db) - (begin - (dbr:dbstruct-set-inmem! dbstruct inmem) - ;; dec 14, 2014 - keep deleted records available. hunch is that they are needed for id placeholders - ;; (sqlite3:execute db "DELETE FROM tests WHERE state='DELETED';") ;; they just slow us down in this context - (db:sync-tables db:sync-tests-only db inmem) - (db:delay-if-busy refdb) ;; dbpath: (db:dbdat-get-path refdb)) ;; What does delaying here achieve? - (dbr:dbstruct-set-refdb! dbstruct refdb) - (db:sync-tables db:sync-tests-only inmem refdb) ;; use inmem as the reference, don't read again from db - ;; sync once more to deal with delays? - ;; (db:sync-tables db:sync-tests-only db inmem) - ;; (db:sync-tables db:sync-tests-only inmem refdb) - inmem))))))) - -;; This routine creates the db. It is only called if the db is not already ls opened -;; -(define (db:open-main dbstruct) ;; (conc *toppath* "/megatest.db") (car *configinfo*))) - (let ((mdb (dbr:dbstruct-get-main dbstruct))) - (if mdb - mdb - (begin - (mutex-lock! *rundb-mutex*) - (let* ((dbpath (db:dbfile-path 0)) - (dbexists (file-exists? dbpath)) - (db (db:lock-create-open dbpath db:initialize-main-db)) - (olddb (db:open-megatest-db)) - (write-access (file-write-access? dbpath)) - (dbdat (cons db dbpath))) - (if (and dbexists (not write-access)) - (set! *db-write-access* #f)) - (dbr:dbstruct-set-main! dbstruct dbdat) - (dbr:dbstruct-set-olddb! dbstruct olddb) ;; olddb is already a (cons db path) - (mutex-unlock! *rundb-mutex*) - (if (and (not dbexists) - *db-write-access*) ;; did not have a prior db and do have write access - (db:multi-db-sync #f 'old2new)) ;; migrate data from megatest.db automatically - dbdat))))) + (condition-case + (let* ((lockfname (conc fname ".lock")) + (readyfname (conc parent-dir "/.ready-" raw-fname)) + (readyexists (common:file-exists? readyfname))) + (if (not readyexists) + (common:simple-file-lock-and-wait lockfname)) + (let ((db (sqlite3:open-database fname))) + (sqlite3:set-busy-handler! db (sqlite3:make-busy-timeout 136000)) + (sqlite3:execute db "PRAGMA synchronous = 0;") + (if (and (configf:lookup *configdat* "setup" "tmp_mode") (string-match "^/tmp/.*" fname)) + (begin + ;;(print "DEBUG: Setting tmp_mode for " fname) + (sqlite3:execute db (configf:lookup *configdat* "setup" "tmp_mode")) + ) + ) + (if (and (configf:lookup *configdat* "setup" "nfs_mode") (not (string-match "^/tmp/.*" fname))) + (begin + ;;(print "DEBUG: Setting nfs_mode for " fname) + (sqlite3:execute db (configf:lookup *configdat* "setup" "nfs_mode")) + ) + ) + (if (and (not (or (configf:lookup *configdat* "setup" "tmp_mode") (configf:lookup *configdat* "setup" "nfs_mode"))) + (configf:lookup *configdat* "setup" "use-wal") + (string-match "^/tmp/.*" fname)) ;; this is a file in /tmp + (sqlite3:execute db "PRAGMA journal_mode=WAL;") + (debug:print 2 *default-log-port* "Creating " fname " in NON-WAL mode.")) + (if (not file-exists) + (initproc db)) + (if (not readyexists) + (begin + (common:simple-file-release-lock lockfname) + (with-output-to-file + readyfname + (lambda () + (print "Ready at " + (seconds->year-work-week/day-time + (current-seconds))))))) + db)) + (exn (io-error) (debug:print 0 *default-log-port* "ERROR: i/o error with " fname ". Check permissions, disk space etc. and try again.")) + (exn (corrupt) (debug:print 0 *default-log-port* "ERROR: database " fname " is corrupt. Repair it to proceed.")) + (exn (busy) (debug:print 0 *default-log-port* "ERROR: database " fname " is locked. Try copying to another location, remove original and copy back.")) + (exn (permission)(debug:print 0 *default-log-port* "ERROR: database " fname " has some permissions problem.")) + (exn () (debug:print 0 *default-log-port* "ERROR: Unknown error with database " fname " message: " ((condition-property-accessor 'exn 'message) exn)))) + + (condition-case + (begin + (debug:print 2 *default-log-port* "WARNING: opening db in non-writable dir " fname) + (let ((db (sqlite3:open-database fname))) + (sqlite3:set-busy-handler! db (sqlite3:make-busy-timeout 136000)) + (sqlite3:execute db "PRAGMA synchronous = 0;") + ;; (mutex-unlock! *db-open-mutex*) + db)) + (exn (io-error) (debug:print 0 *default-log-port* "ERROR: i/o error with " fname ". Check permissions, disk space etc. and try again.")) + (exn (corrupt) (debug:print 0 *default-log-port* "ERROR: database " fname " is corrupt. Repair it to proceed.")) + (exn (busy) (debug:print 0 *default-log-port* "ERROR: database " fname " is locked. Try copying to another location, remove original and copy back.")) + (exn (permission)(debug:print 0 *default-log-port* "ERROR: database " fname " has some permissions problem.")) + (exn () (debug:print 0 *default-log-port* "ERROR: Unknown error with database " fname " message: " ((condition-property-accessor 'exn 'message) exn)))) + ))) + + +;; This routine creates the db if not already present. It is only called if the db is not already opened +;; +(define (db:open-db dbstruct #!key (areapath #f)(do-sync #t)) ;; TODO: actually use areapath + (let ((tmpdb-stack (dbr:dbstruct-dbstack dbstruct))) ;; RA => Returns the first reference in dbstruct + (if (stack? tmpdb-stack) + (db:get-db tmpdb-stack) ;; get previously opened db (will create new db handle if all in the stack are already used + (let* ((max-stale-tmp (configf:lookup-number *configdat* "server" "filling-db-max-stale-seconds" default: 10)) + (dbpath (db:dbfile-path )) ;; path to tmp db area + (dbexists (common:file-exists? dbpath)) + (tmpdbfname (conc dbpath "/megatest.db")) + (dbfexists (common:file-exists? tmpdbfname)) ;; (conc dbpath "/megatest.db"))) + (mtdbexists (common:file-exists? (conc *toppath* "/megatest.db"))) + + (mtdbmodtime (if mtdbexists (common:lazy-sqlite-db-modification-time (conc *toppath* "/megatest.db")) #f)) + (tmpdbmodtime (if dbfexists (common:lazy-sqlite-db-modification-time tmpdbfname) #f)) + (mtdb (db:open-megatest-db)) + (mtdbpath (db:dbdat-get-path mtdb)) + (tmpdb (db:open-megatest-db path: dbpath)) ;; lock-create-open dbpath db:initialize-main-db)) + (refndb (db:open-megatest-db path: dbpath name: "megatest_ref.db")) + (write-access (file-write-access? mtdbpath)) + ;(mtdbmodtime (if mtdbexists (common:lazy-sqlite-db-modification-time mtdbpath) #f)) ; moving this before db:open-megatest-db is called. if wal mode is on -WAL and -shm file get created with causing the tmpdbmodtime timestamp always greater than mtdbmodtime + ;(tmpdbmodtime (if dbfexists (common:lazy-sqlite-db-modification-time tmpdbfname) #f)) + ;if wal mode is on -WAL and -shm file get created when db:open-megatest-db is called. modtimedelta will always be < 10 so db in tmp not get synced + ;(tmpdbmodtime (if dbfexists (db:get-last-update-time (car tmpdb)) #f)) + ;(fmt (file-modification-time tmpdbfname)) + (modtimedelta (and mtdbmodtime tmpdbmodtime (- mtdbmodtime tmpdbmodtime)))) + + (when write-access + (sqlite3:execute (car mtdb) "drop trigger if exists update_tests_trigger") + (sqlite3:execute (car mtdb) "drop trigger if exists update_runs_trigger")) + + ;(print "mtdbmodtime " mtdbmodtime " tmpdbmodtime " tmpdbmodtime " mtdbpath " mtdbpath " " (conc *toppath* "/megatest.db")) + ;;(debug:print-info 13 *default-log-port* "db:open-db>> mtdbpath="mtdbpath" mtdbexists="mtdbexists" and write-access="write-access) + (if (and dbexists (not write-access)) + (begin + (set! *db-write-access* #f) + (dbr:dbstruct-read-only-set! dbstruct #t))) + (dbr:dbstruct-mtdb-set! dbstruct mtdb) + (dbr:dbstruct-tmpdb-set! dbstruct tmpdb) + (dbr:dbstruct-dbstack-set! dbstruct (make-stack)) ;; BB: why a stack? Why would the number of db's be indeterminate? Is this a legacy of 1.db 2.db .. ? + (stack-push! (dbr:dbstruct-dbstack dbstruct) tmpdb) ;; olddb is already a (cons db path) + (dbr:dbstruct-refndb-set! dbstruct refndb) + (if (and (or (not dbfexists) + (and modtimedelta + (> modtimedelta max-stale-tmp))) ;; if db in tmp is over ten seconds older than the file in MTRA then do a sync back + do-sync) + (begin + (debug:print 1 *default-log-port* "filling db " (db:dbdat-get-path tmpdb) " with data \n from " (db:dbdat-get-path mtdb) " mod time delta: " modtimedelta) + (db:sync-tables (db:sync-all-tables-list dbstruct) #f mtdb refndb tmpdb) + ;touch tmp db to avoid wal mode wierdness + (set! (file-modification-time tmpdbfname) (current-seconds)) + (debug:print-info 13 *default-log-port* "db:sync-all-tables-list done.") + ) + (debug:print 4 *default-log-port* " db, " (db:dbdat-get-path tmpdb) " already exists or fresh enough, not propogating data from\n " (db:dbdat-get-path mtdb) " mod time delta: " modtimedelta) ) + ;; (db:multi-db-sync dbstruct 'old2new)) ;; migrate data from megatest.db automatically + tmpdb)))) + + +(define (db:get-last-update-time db) +; (db:with-db +; dbstruct #f #f +; (lambda (db) + (let ((last-update-time #f)) + (sqlite3:for-each-row + (lambda (lup) + (set! last-update-time lup)) + db + "select max(lup) from ( select max(last_update) as lup from tests union select max(last_update) as lup from runs);") + last-update-time)) +;)) ;; Make the dbstruct, setup up auxillary db's and call for main db at least once ;; -(define (db:setup run-id #!key (local #f)) - (let* ((dbdir (db:dbfile-path #f)) ;; (conc (configf:lookup *configdat* "setup" "linktree") "/.db")) - (dbstruct (make-dbr:dbstruct path: dbdir local: local))) - dbstruct)) - -;; Open the classic megatest.db file in toppath -;; -(define (db:open-megatest-db) - (let* ((dbpath (conc *toppath* "/megatest.db")) - (dbexists (file-exists? dbpath)) +;; called in http-transport and replicated in rmt.scm for *local* access. +;; +(define (db:setup do-sync #!key (areapath #f)) + ;; + (cond + (*dbstruct-db* *dbstruct-db*);; TODO: when multiple areas are supported, this optimization will be a hazard + (else ;;(common:on-homehost?) + (debug:print-info 13 *default-log-port* "db:setup entered (first time, not cached.)") + (let* ((dbstruct (make-dbr:dbstruct))) + (when (not *toppath*) + (debug:print-info 13 *default-log-port* "in db:setup, *toppath* not set; calling launch:setup") + (launch:setup areapath: areapath)) + (debug:print-info 13 *default-log-port* "Begin db:open-db") + (db:open-db dbstruct areapath: areapath do-sync: do-sync) + (debug:print-info 13 *default-log-port* "Done db:open-db") + (set! *dbstruct-db* dbstruct) + ;;(debug:print-info 13 *default-log-port* "new dbstruct = "(dbr:dbstruct->alist dbstruct)) + dbstruct)))) + ;; (else + ;; (debug:print 0 *default-log-port* "ERROR: attempt to open database when not on homehost. Exiting. Homehost: " (common:get-homehost)) + ;; (exit 1)))) + +;; Open the classic megatest.db file (defaults to open in toppath) +;; +;; NOTE: returns a dbdat not a dbstruct! +;; + +;;(define (db:reopen-megatest-db + +(define (db:open-megatest-db #!key (path #f)(name #f)) + (let* ((dbdir (or path *toppath*)) + (dbpath (conc dbdir "/" (or name "megatest.db"))) + (dbexists (common:file-exists? dbpath)) (db (db:lock-create-open dbpath (lambda (db) - (db:initialize-main-db db) - (db:initialize-run-id-db db)))) + (db:initialize-main-db db) + ;;(db:initialize-run-id-db db) + ))) (write-access (file-write-access? dbpath))) + (debug:print-info 13 *default-log-port* "db:open-megatest-db "dbpath) (if (and dbexists (not write-access)) (set! *db-write-access* #f)) (cons db dbpath))) ;; sync run to disk if touched ;; (define (db:sync-touched dbstruct run-id #!key (force-sync #f)) - (let ((mtime (dbr:dbstruct-get-mtime dbstruct)) - (stime (dbr:dbstruct-get-stime dbstruct)) - (rundb (dbr:dbstruct-get-rundb dbstruct)) - (inmem (dbr:dbstruct-get-inmem dbstruct)) - (maindb (dbr:dbstruct-get-main dbstruct)) - (refdb (dbr:dbstruct-get-refdb dbstruct)) - (olddb (dbr:dbstruct-get-olddb dbstruct)) - ;; (runid (dbr:dbstruct-get-run-id dbstruct)) - ) + (let ((tmpdb (db:get-db dbstruct)) + (mtdb (dbr:dbstruct-mtdb dbstruct)) + (refndb (dbr:dbstruct-refndb dbstruct)) + (start-t (current-seconds))) (debug:print-info 4 *default-log-port* "Syncing for run-id: " run-id) - ;; (mutex-lock! *http-mutex*) - (if (eq? run-id 0) - ;; runid equal to 0 is main.db - (if maindb - (if (or (not (number? mtime)) - (not (number? stime)) - (> mtime stime) - force-sync) - (begin - (db:delay-if-busy maindb) - (db:delay-if-busy olddb) - (let ((num-synced (db:sync-tables (db:sync-main-list maindb) maindb olddb))) - (dbr:dbstruct-set-stime! dbstruct (current-milliseconds)) - num-synced) - 0)) - (begin - ;; this can occur when using local access (i.e. not in a server) - ;; need a flag to turn it off. - ;; - (debug:print 3 *default-log-port* "WARNING: call to sync main.db to megatest.db but main not initialized") - 0)) - ;; any other runid is a run - (if (or (not (number? mtime)) - (not (number? stime)) - (> mtime stime) - force-sync) - (begin - (db:delay-if-busy rundb) - (db:delay-if-busy olddb) - (dbr:dbstruct-set-stime! dbstruct (current-milliseconds)) - (let ((num-synced (db:sync-tables db:sync-tests-only inmem refdb rundb olddb))) - ;; (mutex-unlock! *http-mutex*) - num-synced) - (begin - ;; (mutex-unlock! *http-mutex*) - 0)))))) - -(define (db:close-main dbstruct) - (let ((maindb (dbr:dbstruct-get-main dbstruct))) - (if maindb - (begin - (sqlite3:finalize! (db:dbdat-get-db maindb)) - (dbr:dbstruct-set-main! dbstruct #f))))) - -(define (db:close-run-db dbstruct run-id) - (let ((rdb (db:open-rundb dbstruct run-id do-not-open: #t))) - (if (and rdb - (sqlite3:database? rdb)) - (begin - (sqlite3:finalize! rdb) - (dbr:dbstruct-set-localdb! dbstruct run-id #f) - (dbr:dbstruct-set-inmem! dbstruct #f))))) + (mutex-lock! *db-multi-sync-mutex*) + (let ((update_info (cons (if force-sync 0 *db-last-sync*) "last_update"))) + (mutex-unlock! *db-multi-sync-mutex*) + (db:sync-tables (db:sync-all-tables-list dbstruct) update_info tmpdb refndb mtdb)) + (mutex-lock! *db-multi-sync-mutex*) + (set! *db-last-sync* start-t) + (set! *db-last-access* start-t) + (mutex-unlock! *db-multi-sync-mutex*) + (stack-push! (dbr:dbstruct-dbstack dbstruct) tmpdb))) + +(define (db:safely-close-sqlite3-db db stmt-cache #!key (try-num 3)) + (if (<= try-num 0) + #f + (handle-exceptions + exn + (begin + (print "Attempt to safely close sqlite3 db failed. Trying again. exn=" exn) + (thread-sleep! 3) + (sqlite3:interrupt! db) + (db:safely-close-sqlite3-db db stmtcache try-num: (- try-num 1))) + (if (sqlite3:database? db) + (let* ((stmts (and stmt-cache (hash-table-ref/default stmt-cache db #f)))) + (if stmts (map sqlite3:finalize! (hash-table-values stmts))) + (sqlite3:finalize! db) + #t) + #f)))) ;; close all opened run-id dbs (define (db:close-all dbstruct) - ;; finalize main.db - (db:sync-touched dbstruct 0 force-sync: #t) - ;;(common:db-block-further-queries) - ;; (mutex-lock! *db-sync-mutex*) ;; with this perhaps it isn't necessary to use the block-further-queries mechanism? - - (db:close-main dbstruct) - - (let ((locdbs (dbr:dbstruct-get-locdbs dbstruct))) - (if (hash-table? locdbs) - (for-each (lambda (run-id) - (db:close-run-db dbstruct run-id)) - (hash-table-keys locdbs))))) - -(define (db:open-inmem-db) - (let* ((db (sqlite3:open-database ":memory:")) - (handler (make-busy-timeout 3600))) - (sqlite3:set-busy-handler! db handler) - (db:initialize-run-id-db db) - (cons db #f))) + (if (dbr:dbstruct? dbstruct) + (handle-exceptions + exn + (begin + (debug:print 0 *default-log-port* "WARNING: Finalizing failed, " ((condition-property-accessor 'exn 'message) exn) ", note - exn=" exn) + (print-call-chain *default-log-port*)) + ;; (db:sync-touched dbstruct 0 force-sync: #t) ;; NO. Do not do this here. Instead we rely on a server to be started when there are writes, even if the server itself is not going to be used as a server. + (let ((tdbs (map db:dbdat-get-db + (stack->list (dbr:dbstruct-dbstack dbstruct)))) + (mdb (db:dbdat-get-db (dbr:dbstruct-mtdb dbstruct))) + (rdb (db:dbdat-get-db (dbr:dbstruct-refndb dbstruct))) + (stmt-cache (dbr:dbstruct-stmt-cache dbstruct))) + (map (lambda (db) + (db:safely-close-sqlite3-db db stmt-cache)) + tdbs) + (db:safely-close-sqlite3-db mdb stmt-cache) ;; (if (sqlite3:database? mdb) (sqlite3:finalize! mdb)) + (db:safely-close-sqlite3-db rdb stmt-cache))))) ;; (if (sqlite3:database? rdb) (sqlite3:finalize! rdb)))))) + +;; (let ((locdbs (dbr:dbstruct-locdbs dbstruct))) +;; (if (hash-table? locdbs) +;; (for-each (lambda (run-id) +;; (db:close-run-db dbstruct run-id)) +;; (hash-table-keys locdbs))))) + +;; (define (db:open-inmem-db) +;; (let* ((db (sqlite3:open-database ":memory:")) +;; (handler (make-busy-timeout 3600))) +;; (sqlite3:set-busy-handler! db handler) +;; (db:initialize-run-id-db db) +;; (cons db #f))) ;; just tests, test_steps and test_data tables (define db:sync-tests-only (list ;; (list "strs" @@ -422,20 +525,22 @@ '("run_duration" #f) '("comment" #f) '("event_time" #f) '("fail_count" #f) '("pass_count" #f) - '("archived" #f)) + '("archived" #f) + '("last_update" #f)) (list "test_steps" '("id" #f) '("test_id" #f) '("stepname" #f) '("state" #f) '("status" #f) '("event_time" #f) '("comment" #f) - '("logfile" #f)) + '("logfile" #f) + '("last_update" #f)) (list "test_data" '("id" #f) '("test_id" #f) '("category" #f) '("variable" #f) @@ -443,16 +548,17 @@ '("expected" #f) '("tol" #f) '("units" #f) '("comment" #f) '("status" #f) - '("type" #f)))) + '("type" #f) + '("last_update" #f)))) ;; needs db to get keys, this is for syncing all tables ;; -(define (db:sync-main-list db) - (let ((keys (db:get-keys db))) +(define (db:sync-main-list dbstruct) + (let ((keys (db:get-keys dbstruct))) (list (list "keys" '("id" #f) '("fieldname" #f) '("fieldtype" #f)) @@ -459,11 +565,27 @@ (list "metadat" '("var" #f) '("val" #f)) (append (list "runs" '("id" #f)) (map (lambda (k)(list k #f)) (append keys - (list "runname" "state" "status" "owner" "event_time" "comment" "fail_count" "pass_count")))) + (list "runname" "state" "status" "owner" "event_time" "comment" "fail_count" "pass_count" "contour" "last_update")))) + (list "archive_disks" + '("id" #f) + '("archive_area_name" #f) + '("disk_path" #f) + '("last_df" #f) + '("last_df_time" #f) + '("creation_time" #f)) + + (list "archive_blocks" + '("id" #f) + '("archive_disk_id" #f) + '("disk_path" #f) + '("last_du" #f) + '("last_du_time" #f) + '("creation_time" #f)) + (list "test_meta" '("id" #f) '("testname" #f) '("owner" #f) '("description" #f) @@ -471,10 +593,14 @@ '("iterated" #f) '("avg_runtime" #f) '("avg_disk" #f) '("tags" #f) '("jobgroup" #f))))) + +(define (db:sync-all-tables-list dbstruct) + (append (db:sync-main-list dbstruct) + db:sync-tests-only)) ;; use bunch of Unix commands to try to break the lock and recreate the db ;; (define (db:move-and-recreate-db dbdat) (let* ((dbpath (db:dbdat-get-path dbdat)) @@ -484,11 +610,11 @@ (tmpname (conc fname "." (current-process-id))) (tmpjnl (conc fnamejnl "." (current-process-id)))) (debug:print-error 0 *default-log-port* "" fname " appears corrupted. Making backup \"old/" fname "\"") (system (conc "cd " dbdir ";mkdir -p old;cat " fname " > old/" tmpname)) (system (conc "rm -f " dbpath)) - (if (file-exists? fnamejnl) + (if (common:file-exists? fnamejnl) (begin (debug:print-error 0 *default-log-port* "" fnamejnl " found, moving it to old dir as " tmpjnl) (system (conc "cd " dbdir ";mkdir -p old;cat " fnamejnl " > old/" tmpjnl)) (system (conc "rm -f " dbdir "/" fnamejnl)))) ;; attempt to recreate database @@ -513,10 +639,11 @@ ;; (else ;; ((equal? fname "megatest.db") ;; this file can be regenerated if needed (handle-exceptions exn (begin + (print "Problems trying to repair the db, exn=" exn) ;; (db:move-and-recreate-db dbdat) (if (> numtries 0) (db:repair-db dbdat numtries: (- numtries 1)) #f) (debug:print 0 *default-log-port* "FATAL: file " dbpath " was found corrupted, an attempt to fix has been made but you must start over.") @@ -531,10 +658,12 @@ "\"\n") (exit) ;; we can not safely continue when a db was corrupted - even if fixed. ) ;; test read/write access to the database (let ((db (sqlite3:open-database dbpath))) + (sqlite3:set-busy-handler! db (sqlite3:make-busy-timeout 136000)) + (sqlite3:execute db "PRAGMA synchronous = 0;") (cond ((equal? fname "megatest.db") (sqlite3:execute db "DELETE FROM tests WHERE state='DELETED';")) ((equal? fname "main.db") (sqlite3:execute db "DELETE FROM runs WHERE state='deleted';")) @@ -543,26 +672,28 @@ ((equal? fname "monitor.db") (sqlite3:execute "DELETE FROM servers WHERE state LIKE 'defunct%';")) (else (sqlite3:execute db "vacuum;"))) - (finalize! db) + (sqlite3:finalize! db) #t)))))) ;; tbls is ( ("tablename" ( "field1" [#f|proc1] ) ( "field2" [#f|proc2] ) .... ) ) ;; db's are dbdat's ;; -(define (db:sync-tables tbls fromdb todb . slave-dbs) - (mutex-lock! *db-sync-mutex*) +;; if last-update specified ("field-name" . time-in-seconds) +;; then sync only records where field-name >= time-in-seconds +;; IFF field-name exists +;; +(define (db:sync-tables tbls last-update fromdb todb . slave-dbs) (handle-exceptions exn (begin - (mutex-unlock! *db-sync-mutex*) (debug:print 0 *default-log-port* "EXCEPTION: database probably overloaded or unreadable in db:sync-tables.") (print-call-chain (current-error-port)) (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) - (print "exn=" (condition->list exn)) + (debug:print 5 *default-log-port* "exn=" (condition->list exn)) (debug:print 0 *default-log-port* " status: " ((condition-property-accessor 'sqlite3 'status) exn)) (debug:print 0 *default-log-port* " src db: " (db:dbdat-get-path fromdb)) (for-each (lambda (dbdat) (let ((dbpath (db:dbdat-get-path dbdat))) (debug:print 0 *default-log-port* " dbpath: " dbpath) @@ -571,49 +702,91 @@ (debug:print-error 0 *default-log-port* "Failed to rebuild " dbpath ", exiting now.") (exit))))) (cons todb slave-dbs)) 0) -;; (if *server-run* ;; we are inside a server, throw a sync-failed error -;; (signal (make-composite-condition -;; (make-property-condition 'sync-failed 'message "db:sync-tables failed in a server context."))) -;; 0)) ;; return zero for num synced - - ;; (set! *time-to-exit* #t) ;; let watch dog know that it is time to die. - ;; (tasks:server-set-state! (db:delay-if-busy tdbdat) server-id "shutting-down") - ;; (portlogger:open-run-close portlogger:set-port port "released") - ;; (exit 1))) + ;; this is the work to be done (cond - ((not fromdb) (debug:print 3 *default-log-port* "WARNING: db:sync-tables called with fromdb missing") -1) - ((not todb) (debug:print 3 *default-log-port* "WARNING: db:sync-tables called with todb missing") -2) + ((not fromdb) (debug:print 3 *default-log-port* "WARNING: db:sync-tables called with fromdb missing") + -1) + ((not todb) (debug:print 3 *default-log-port* "WARNING: db:sync-tables called with todb missing") + -2) ((not (sqlite3:database? (db:dbdat-get-db fromdb))) - (debug:print-error 0 *default-log-port* "db:sync-tables called with fromdb not a database " fromdb) -3) + (debug:print-error 0 *default-log-port* "db:sync-tables called with fromdb not a database " fromdb) + -3) ((not (sqlite3:database? (db:dbdat-get-db todb))) - (debug:print-error 0 *default-log-port* "db:sync-tables called with todb not a database " todb) -4) + (debug:print-error 0 *default-log-port* "db:sync-tables called with todb not a database " todb) + -4) + + ((not (file-write-access? (db:dbdat-get-path todb))) + (debug:print-error 0 *default-log-port* "db:sync-tables called with todb not a read-only database " todb) + -5) + ((not (null? (let ((readonly-slave-dbs + (filter + (lambda (dbdat) + (not (file-write-access? (db:dbdat-get-path todb)))) + slave-dbs))) + (for-each + (lambda (bad-dbdat) + (debug:print-error + 0 *default-log-port* "db:sync-tables called with todb not a read-only database " bad-dbdat)) + readonly-slave-dbs) + readonly-slave-dbs))) -6) (else (let ((stmts (make-hash-table)) ;; table-field => stmt (all-stmts '()) ;; ( ( stmt1 value1 ) ( stml2 value2 )) (numrecs (make-hash-table)) (start-time (current-milliseconds)) (tot-count 0)) (for-each ;; table (lambda (tabledat) - (let* ((tablename (car tabledat)) - (fields (cdr tabledat)) + (let* ((tablename (car tabledat)) + (fields (cdr tabledat)) + (has-last-update (member "last_update" fields)) + (use-last-update (cond + ((and has-last-update + (member "last_update" fields)) + #t) ;; if given a number, just use it for all fields + ((number? last-update) #f) ;; if not matched first entry then ignore last-update for this table + ((and (pair? last-update) + (member (car last-update) ;; last-update field name + (map car fields))) + #t) + (last-update + (debug:print 0 *default-log-port* "ERROR: parameter last-update for db:sync-tables must be a pair or a number, received: " last-update);; found in fields + #f) + (else + #f))) + (last-update-value (if use-last-update ;; no need to check for has-last-update - it is already accounted for + (if (number? last-update) + last-update + (cdr last-update)) + #f)) + (last-update-field (if use-last-update + (if (number? last-update) + "last_update" + (car last-update)) + #f)) (num-fields (length fields)) (field->num (make-hash-table)) - (num->field (apply vector (map car fields))) + (num->field (apply vector (map car fields))) ;; BBHERE (full-sel (conc "SELECT " (string-intersperse (map car fields) ",") - " FROM " tablename ";")) + " FROM " tablename (if use-last-update ;; apply last-update criteria + (conc " WHERE " last-update-field " >= " last-update-value) + "") + ";")) (full-ins (conc "INSERT OR REPLACE INTO " tablename " ( " (string-intersperse (map car fields) ",") " ) " " VALUES ( " (string-intersperse (make-list num-fields "?") ",") " );")) (fromdat '()) (fromdats '()) (totrecords 0) - (batch-len (string->number (or (configf:lookup *configdat* "sync" "batchsize") "10"))) + (batch-len (string->number (or (configf:lookup *configdat* "sync" "batchsize") "100"))) (todat (make-hash-table)) - (count 0)) + (count 0) + (field-names (map car fields)) + (delay-handicap (string->number (or (configf:lookup *configdat* "sync" "delay-handicap") "0"))) + ) ;; set up the field->num table (for-each (lambda (field) (hash-table-set! field->num field count) @@ -637,23 +810,37 @@ (set! fromdats (cons fromdat fromdats))) (if (common:low-noise-print 120 "sync-records") (debug:print-info 4 *default-log-port* "found " totrecords " records to sync")) - ;; read the target table + ;; read the target table; BBHERE (sqlite3:for-each-row (lambda (a . b) (hash-table-set! todat a (apply vector a b))) (db:dbdat-get-db todb) full-sel) + (when (and delay-handicap (> delay-handicap 0)) + (debug:print-info 0 *default-log-port* "imposing synthetic sync delay of "delay-handicap" seconds since sync/delay-handicap is configured") + (thread-sleep! delay-handicap) + (debug:print-info 0 *default-log-port* "synthetic sync delay of "delay-handicap" seconds completed") + ) + ;; first pass implementation, just insert all changed rows (for-each (lambda (targdb) - (let* ((db (db:dbdat-get-db targdb)) + (let* ((db (db:dbdat-get-db targdb)) + (drp-trigger (if (member "last_update" field-names) + (db:drop-trigger db tablename) + #f)) + (is-trigger-dropped (if (member "last_update" field-names) + (db:is-trigger-dropped db tablename) + #f)) (stmth (sqlite3:prepare db full-ins))) ;; (db:delay-if-busy targdb) ;; NO WAITING + (if (member "last_update" field-names) + (debug:print-info 3 *default-log-port* "is-trigger-dropped: " is-trigger-dropped)) (for-each (lambda (fromdat-lst) (sqlite3:with-transaction db (lambda () @@ -671,202 +858,332 @@ (loop (+ i 1)))) (if (not same) (begin (apply sqlite3:execute stmth (vector->list fromrow)) (hash-table-set! numrecs tablename (+ 1 (hash-table-ref/default numrecs tablename 0))))))) - fromdat-lst)) - )) + fromdat-lst)))) fromdats) - (sqlite3:finalize! stmth))) + (sqlite3:finalize! stmth) + (if (member "last_update" field-names) + (db:create-trigger db tablename)))) (append (list todb) slave-dbs)))) tbls) (let* ((runtime (- (current-milliseconds) start-time)) - (should-print (common:low-noise-print 120 "db sync" (> runtime 500)))) ;; low and high sync times treated as separate. + (should-print (or (debug:debug-mode 12) + (common:low-noise-print 120 "db sync" (> runtime 500))))) ;; low and high sync times treated as separate. (if should-print (debug:print 3 *default-log-port* "INFO: db sync, total run time " runtime " ms")) (for-each (lambda (dat) (let ((tblname (car dat)) (count (cdr dat))) (set! tot-count (+ tot-count count)) (if (> count 0) (if should-print (debug:print 0 *default-log-port* (format #f " ~10a ~5a" tblname count)))))) (sort (hash-table->alist numrecs)(lambda (a b)(> (cdr a)(cdr b)))))) - tot-count))) - (mutex-unlock! *db-sync-mutex*))) - -;; options: -;; -;; 'killservers - kills all servers -;; 'dejunk - removes junk records -;; 'adj-testids - move test-ids into correct ranges -;; 'old2new - sync megatest.db records to .db/{main,1,2 ...}.db -;; 'new2old - sync .db/{main,1,2,3 ...}.db to megatest.db -;; 'closeall - close all opened dbs -;; -;; run-ids: '(1 2 3 ...) or #f (for all) -;; -(define (db:multi-db-sync run-ids . options) - (let* ((toppath (launch:setup)) - (dbstruct (if toppath (make-dbr:dbstruct path: toppath) #f)) - (mtdb (if toppath (db:open-megatest-db))) - (allow-cleanup (if run-ids #f #t)) - (run-ids (if run-ids - run-ids - (if toppath (begin - (db:delay-if-busy mtdb) - (db:get-all-run-ids mtdb))))) - (tdbdat (tasks:open-db)) - (servers (tasks:get-all-servers (db:delay-if-busy tdbdat)))) - - ;; kill servers - (if (member 'killservers options) - (for-each - (lambda (server) - (tasks:server-delete-record (db:delay-if-busy tdbdat) (vector-ref server 0) "dbmigration") - (tasks:kill-server (vector-ref server 2)(vector-ref server 1))) - servers)) - - ;; clear out junk records - ;; - (if (member 'dejunk options) - (begin - (db:delay-if-busy mtdb) - (db:clean-up mtdb))) - - ;; adjust test-ids to fit into proper range - ;; - (if (member 'adj-testids options) - (begin - (db:delay-if-busy mtdb) - (db:prep-megatest.db-for-migration mtdb))) - - ;; sync runs, test_meta etc. - ;; - (if (member 'old2new options) - (begin - (db:sync-tables (db:sync-main-list mtdb) mtdb (db:get-db dbstruct #f)) - (for-each - (lambda (run-id) - (db:delay-if-busy mtdb) - (let ((testrecs (db:get-all-tests-info-by-run-id mtdb run-id)) - (dbstruct (if toppath (make-dbr:dbstruct path: toppath local: #t) #f))) - (debug:print 0 *default-log-port* "INFO: Propagating " (length testrecs) " records for run-id=" run-id " to run specific db") - (db:replace-test-records dbstruct run-id testrecs) - (sqlite3:finalize! (db:dbdat-get-db (dbr:dbstruct-get-rundb dbstruct))))) - run-ids))) - - ;; now ensure all newdb data are synced to megatest.db - ;; do not use the run-ids list passed in to the function - ;; - (if (member 'new2old options) - (let* ((maindb (make-dbr:dbstruct path: toppath local: #t)) - (src-run-ids (if run-ids run-ids (db:get-all-run-ids (db:dbdat-get-db (db:get-db maindb 0))))) - (all-run-ids (sort (delete-duplicates (cons 0 src-run-ids)) <)) - (count 1) - (total (length all-run-ids)) - (dead-runs '())) - (for-each - (lambda (run-id) - (debug:print 0 *default-log-port* "Processing run " (if (eq? run-id 0) " main.db " run-id) ", " count " of " total) - (set! count (+ count 1)) - (let* ((fromdb (if toppath (make-dbr:dbstruct path: toppath local: #t) #f)) - (frundb (db:dbdat-get-db (db:get-db fromdb run-id)))) - ;; (db:delay-if-busy frundb) - ;; (db:delay-if-busy mtdb) - ;; (db:clean-up frundb) - (if (eq? run-id 0) - (let ((maindb (db:dbdat-get-db (db:get-db fromdb #f)))) - (db:sync-tables (db:sync-main-list dbstruct) (db:get-db fromdb #f) mtdb) - (set! dead-runs (db:clean-up-maindb (db:get-db fromdb #f))) - ;; - ;; Feb 18, 2016: add field last_update to runs table - ;; - ;; remove all these some time after september 2016 (added in v1.6031 - ;; - (handle-exceptions - exn - (if (string-match ".*duplicate.*" ((condition-property-accessor 'exn 'message) exn)) - (debug:print 0 *default-log-port* "Column last_update already added to runs table") - (db:general-sqlite-error-dump exn "alter table runs ..." run-id "none")) - (sqlite3:execute - maindb - "ALTER TABLE runs ADD COLUMN last_update INTEGER DEFAULT 0")) - ;; these schema changes don't need exception handling - (sqlite3:execute - maindb - "CREATE TRIGGER IF NOT EXISTS update_runs_trigger AFTER UPDATE ON runs + tot-count))))) + +(define (db:patch-schema-rundb frundb) + ;; + ;; remove this some time after September 2016 (added in version v1.6031 + ;; + (for-each + (lambda (table-name) + (handle-exceptions + exn + (if (string-match ".*duplicate.*" ((condition-property-accessor 'exn 'message) exn)) + (debug:print 0 *default-log-port* "Column last_update already added to " table-name " table") + (db:general-sqlite-error-dump exn "alter table " table-name " ..." #f "none")) + (sqlite3:execute + frundb + (conc "ALTER TABLE " table-name " ADD COLUMN last_update INTEGER DEFAULT 0"))) + (sqlite3:execute + frundb + (conc "DROP TRIGGER IF EXISTS update_" table-name "_trigger;")) + (sqlite3:execute + frundb + (conc "CREATE TRIGGER IF NOT EXISTS update_" table-name "_trigger AFTER UPDATE ON " table-name " + FOR EACH ROW + BEGIN + UPDATE " table-name " SET last_update=(strftime('%s','now')) + WHERE id=old.id; + END;")) + ) + '("tests" "test_steps" "test_data"))) + +(define (db:patch-schema-maindb maindb) + ;; + ;; remove all these some time after september 2016 (added in v1.6031 + ;; + (for-each + (lambda (column type default) + (handle-exceptions + exn + (if (string-match ".*duplicate.*" ((condition-property-accessor 'exn 'message) exn)) + (debug:print 0 *default-log-port* "Column " column " already added to runs table") + (db:general-sqlite-error-dump exn "alter table runs ..." #f "none")) + (sqlite3:execute + maindb + (conc "ALTER TABLE runs ADD COLUMN " column " " type " DEFAULT " default)))) + (list "last_update" "contour") + (list "INTEGER" "TEXT" ) + (list "0" "''" )) + ;; these schema changes don't need exception handling + (sqlite3:execute + maindb + "CREATE TRIGGER IF NOT EXISTS update_runs_trigger AFTER UPDATE ON runs FOR EACH ROW BEGIN UPDATE runs SET last_update=(strftime('%s','now')) WHERE id=old.id; END;") - (sqlite3:execute maindb "CREATE TABLE IF NOT EXISTS run_stats ( + (sqlite3:execute maindb "CREATE TABLE IF NOT EXISTS run_stats ( id INTEGER PRIMARY KEY, run_id INTEGER, state TEXT, status TEXT, count INTEGER, last_update INTEGER DEFAULT (strftime('%s','now')))") - (sqlite3:execute maindb "CREATE TRIGGER IF NOT EXISTS update_run_stats_trigger AFTER UPDATE ON run_stats + (sqlite3:execute maindb "CREATE TRIGGER IF NOT EXISTS update_run_stats_trigger AFTER UPDATE ON run_stats FOR EACH ROW BEGIN UPDATE run_stats SET last_update=(strftime('%s','now')) WHERE id=old.id; END;") - ) - (begin - ;; NB// must sync first to ensure deleted tests get marked as such in megatest.db - (db:sync-tables db:sync-tests-only (db:get-db fromdb run-id) mtdb) - (db:clean-up-rundb (db:get-db fromdb run-id)) - ;; - ;; Feb 18, 2016: add field last_update to tests, test_steps and test_data - ;; - ;; remove this some time after September 2016 (added in version v1.6031 - ;; - (for-each - (lambda (table-name) - (handle-exceptions - exn - (if (string-match ".*duplicate.*" ((condition-property-accessor 'exn 'message) exn)) - (debug:print 0 *default-log-port* "Column last_update already added to " table-name " table") - (db:general-sqlite-error-dump exn "alter table " table-name " ..." #f "none")) - (sqlite3:execute - frundb - (conc "ALTER TABLE " table-name " ADD COLUMN last_update INTEGER DEFAULT 0"))) - (sqlite3:execute - frundb - (conc "DROP TRIGGER IF EXISTS update_" table-name "_trigger;")) - (sqlite3:execute - frundb - (conc "CREATE TRIGGER IF NOT EXISTS update_" table-name "_trigger AFTER UPDATE ON " table-name " - FOR EACH ROW - BEGIN - UPDATE " table-name " SET last_update=(strftime('%s','now')) - WHERE id=old.id; - END;")) - ) - '("tests" "test_steps" "test_data")))))) - all-run-ids) - ;; removed deleted runs - (let ((dbdir (tasks:get-task-db-path))) - (for-each (lambda (run-id) - (let ((fullname (conc dbdir "/" run-id ".db"))) - (if (file-exists? fullname) - (begin - (debug:print 0 *default-log-port* "Removing database file for deleted run " fullname) - (delete-file fullname))))) - dead-runs)))) - - ;; (db:close-all dbstruct) - ;; (sqlite3:finalize! mdb) - )) + (sqlite3:execute maindb "CREATE TABLE IF NOT EXISTS test_rundat ( + id INTEGER PRIMARY KEY, + test_id INTEGER, + update_time TIMESTAMP, + cpuload INTEGER DEFAULT -1, + diskfree INTEGER DEFAULT -1, + diskusage INTGER DEFAULT -1, + run_duration INTEGER DEFAULT 0);")) + +(define (db:adj-target db) + (let ((fields (configf:get-section *configdat* "fields")) + (field-num 0)) + ;; because we will be refreshing the keys table it is best to clear it here + (sqlite3:execute db "DELETE FROM keys;") + (for-each + (lambda (field) + (let ((column (car field)) + (spec (cadr field))) + (handle-exceptions + exn + (if (string-match ".*duplicate.*" ((condition-property-accessor 'exn 'message) exn)) + (debug:print 0 *default-log-port* "Target field " column " already exists in the runs table") + (db:general-sqlite-error-dump exn "alter table runs ..." #f "none")) + ;; Add the column if needed + (sqlite3:execute + db + (conc "ALTER TABLE runs ADD COLUMN " column " " spec))) + ;; correct the entry in the keys column + (sqlite3:execute + db + "INSERT INTO keys (id,fieldname,fieldtype) VALUES (?,?,?);" + field-num column spec) + ;; fill in blanks (not allowed as it would be part of the path + (sqlite3:execute + db + (conc "UPDATE runs SET " column "='x' WHERE " column "='';")) + (set! field-num (+ field-num 1)))) + fields))) + +(define *global-db-store* (make-hash-table)) + +(define (db:get-access-mode) + (if (args:get-arg "-use-db-cache") 'cached 'rmt)) + +;; Add db direct +;; +(define (db:dispatch-query access-mode rmt-cmd db-cmd . params) + (if (eq? access-mode 'cached) + (debug:print 2 *default-log-port* "not doing cached calls right now")) +;; (apply db:call-with-cached-db db-cmd params) + (apply rmt-cmd params)) +;;) + +;; return the target db handle so it can be used +;; +(define (db:cache-for-read-only source target #!key (use-last-update #f)) + (if (and (hash-table-ref/default *global-db-store* target #f) + (>= (file-modification-time target)(file-modification-time source))) + (hash-table-ref *global-db-store* target) + (let* ((toppath (launch:setup)) + (targ-db-last-mod (if (common:file-exists? target) + (file-modification-time target) + 0)) + (cache-db (or (hash-table-ref/default *global-db-store* target #f) + (db:open-megatest-db path: target))) + (source-db (db:open-megatest-db path: source)) + (curr-time (current-seconds)) + (res '()) + (last-update (if use-last-update (cons "last_update" targ-db-last-mod) #f))) + (db:sync-tables (db:sync-main-list source-db) last-update source-db cache-db) + (db:sync-tables db:sync-tests-only last-update source-db cache-db) + (hash-table-set! *global-db-store* target cache-db) + cache-db))) + +;; ;; call a proc with a cached db +;; ;; +;; (define (db:call-with-cached-db proc . params) +;; ;; first cache the db in /tmp +;; (let* ((cname-part (conc "megatest_cache/" (common:get-testsuite-name))) +;; (fname (conc (common:get-area-path-signature) ".db")) +;; (cache-dir (common:get-create-writeable-dir +;; (list (conc "/tmp/" (current-user-name) "/" cname-part) +;; (conc "/tmp/" (current-user-name) "-" cname-part) +;; (conc "/tmp/" (current-user-name) "_" cname-part)))) +;; (megatest-db (conc *toppath* "/megatest.db"))) +;; ;; (debug:print-info 0 *default-log-port* "Using cache dir " cache-dir) +;; (if (not cache-dir) +;; (begin +;; (debug:print 0 *default-log-port* "ERROR: Failed to find an area to write the cache db") +;; (exit 1)) +;; (let* ((th1 (make-thread +;; (lambda () +;; (if (and (common:file-exists? megatest-db) +;; (file-write-access? megatest-db)) +;; (begin +;; (db:sync-to-megatest.db dbstruct 'timestamps) ;; internally mutexes on *db-local-sync* +;; (debug:print-info 2 *default-log-port* "Done syncing to megatest.db")))) +;; "call-with-cached-db sync-to-megatest.db")) +;; (cache-db (db:cache-for-read-only +;; megatest-db +;; (conc cache-dir "/" fname) +;; use-last-update: #t))) +;; (thread-start! th1) +;; (apply proc cache-db params) +;; )))) + +;; options: +;; +;; 'killservers - kills all servers +;; 'dejunk - removes junk records +;; 'adj-testids - move test-ids into correct ranges +;; 'old2new - sync megatest.db to /tmp/.../megatest.db and /tmp/.../megatest_ref.db +;; 'new2old - sync /tmp/.../megatest.db to megatest.db and /tmp/.../megatest_ref.db (and update data_synced) +;; 'closeall - close all opened dbs +;; 'schema - attempt to apply schema changes +;; run-ids: '(1 2 3 ...) or #f (for all) +;; +(define (db:multi-db-sync dbstruct . options) + ;; (if (not (launch:setup)) + ;; (debug:print 0 *default-log-port* "ERROR: not able to setup up for megatest.") + (let* ((mtdb (dbr:dbstruct-mtdb dbstruct)) + (tmpdb (db:get-db dbstruct)) + (refndb (dbr:dbstruct-refndb dbstruct)) + (allow-cleanup #t) ;; (if run-ids #f #t)) + (servers (server:get-list *toppath*)) ;; (tasks:get-all-servers (db:delay-if-busy tdbdat))) + (data-synced 0)) ;; count of changed records (I hope) + + (for-each + (lambda (option) + + (case option + ;; kill servers + ((killservers) + (for-each + (lambda (server) + (match-let (((mod-time host port start-time pid) server)) + (if (and host pid) + (tasks:kill-server host pid)))) + servers) + + ;; /tmp/bjbarcla/megatest_localdb/fullrun/.nfs.pdx.disks.icf_env_disk001.bjbarcla.gwa.issues.mtdev.matt-bisect.megatest.ext-tests.runs.all.v1.65.1.6524.dev.bb-24-justrollup-f8.rollup.fullrun/megatest.db.lock + (delete-file* (common:get-sync-lock-filepath)) + ) + + ;; clear out junk records + ;; + ((dejunk) + ;; (db:delay-if-busy mtdb) ;; ok to delay on mtdb + (when (file-write-access? (db:dbdat-get-path mtdb)) (db:clean-up mtdb)) + (db:clean-up tmpdb) + (db:clean-up refndb)) + + ;; sync runs, test_meta etc. + ;; + ((old2new) + (set! data-synced + (+ (db:sync-tables (db:sync-all-tables-list dbstruct) #f mtdb tmpdb refndb) + data-synced))) + + ;; now ensure all newdb data are synced to megatest.db + ;; do not use the run-ids list passed in to the function + ;; + ((new2old) + (set! data-synced + (+ (db:sync-tables (db:sync-all-tables-list dbstruct) #f tmpdb refndb mtdb) + data-synced))) + + ((adj-target) + (db:adj-target (db:dbdat-get-db mtdb)) + (db:adj-target (db:dbdat-get-db tmpdb)) + (db:adj-target (db:dbdat-get-db refndb))) + + ((schema) + (db:patch-schema-maindb (db:dbdat-get-db mtdb)) + (db:patch-schema-maindb (db:dbdat-get-db tmpdb)) + (db:patch-schema-maindb (db:dbdat-get-db refndb)) + (db:patch-schema-rundb (db:dbdat-get-db mtdb)) + (db:patch-schema-rundb (db:dbdat-get-db tmpdb)) + (db:patch-schema-rundb (db:dbdat-get-db refndb)))) + + (stack-push! (dbr:dbstruct-dbstack dbstruct) tmpdb)) + options) + data-synced)) + +(define (db:tmp->megatest.db-sync dbstruct last-update) + (let* ((mtdb (dbr:dbstruct-mtdb dbstruct)) + (tmpdb (db:get-db dbstruct)) + (refndb (dbr:dbstruct-refndb dbstruct)) + (res (db:sync-tables (db:sync-all-tables-list dbstruct) last-update tmpdb refndb mtdb))) + (stack-push! (dbr:dbstruct-dbstack dbstruct) tmpdb) + res)) + +;;;; run-ids +;; if #f use *db-local-sync* : or 'local-sync-flags +;; if #t use timestamps : or 'timestamps +;; +;; NB// no-sync-db is the db handle, not a flag! +;; +(define (db:sync-to-megatest.db dbstruct #!key (no-sync-db #f)) + (let* ((start-time (current-seconds)) + (last-full-update (if no-sync-db + (db:no-sync-get/default no-sync-db "LAST_FULL_UPDATE" 0) + 0)) + (full-sync-needed (> (- start-time last-full-update) 3600)) ;; every hour do a full sync + (last-update (if full-sync-needed + 0 + (if no-sync-db + (db:no-sync-get/default no-sync-db "LAST_UPDATE" 0) + 0))) ;; (or (db:get-var dbstruct "LAST_UPDATE") 0)) + (sync-needed (> (- start-time last-update) 6)) + (res (if (or sync-needed ;; don't sync if a sync already occurred in the past 6 seconds + full-sync-needed) + (begin + (if no-sync-db + (begin + (if full-sync-needed (db:no-sync-set no-sync-db "LAST_FULL_UPDATE" start-time)) + (db:no-sync-set no-sync-db "LAST_UPDATE" start-time))) + (db:tmp->megatest.db-sync dbstruct last-update)) + 0)) + (sync-time (- (current-seconds) start-time))) + (debug:print-info 3 *default-log-port* "Sync of newdb to olddb completed in " sync-time " seconds pid="(current-process-id)) + (if (common:low-noise-print 30 "sync new to old") + (if sync-needed + (debug:print-info 0 *default-log-port* "Sync of " res " records from newdb to olddb completed in " sync-time " seconds pid="(current-process-id)) + (debug:print-info 0 *default-log-port* "No sync needed, last updated " (- start-time last-update) " seconds ago"))) + res)) ;; keeping it around for debugging purposes only -(define (open-run-close-no-exception-handling proc idb . params) +#;(define (open-run-close-no-exception-handling proc idb . params) (debug:print-info 11 *default-log-port* "open-run-close-no-exception-handling START given a db=" (if idb "yes " "no ") ", params=" params) + (print "I don't work anymore. open-run-close-no-exception-handling needs fixing or removing...") + (exit) (if (or *db-write-access* - (not (member proc *db:all-write-procs*))) + (not #t)) ;; was: (member proc * db:all-write-procs *))) (let* ((db (cond ((pair? idb) (db:dbdat-get-db idb)) ((sqlite3:database? idb) idb) ((not idb) (debug:print-error 0 *default-log-port* "cannot open-run-close with #f anymore")) ((procedure? idb) (idb)) @@ -876,11 +1193,11 @@ (if (not idb)(sqlite3:finalize! dbstruct)) (debug:print-info 11 *default-log-port* "open-run-close-no-exception-handling END" ) res) #f)) -(define (open-run-close-exception-handling proc idb . params) +#;(define (open-run-close-exception-handling proc idb . params) (handle-exceptions exn (let ((sleep-time (random 30)) (err-status ((condition-property-accessor 'sqlite3 'status #f) exn))) (case err-status @@ -887,80 +1204,178 @@ ((busy) (thread-sleep! sleep-time)) (else (debug:print 0 *default-log-port* "EXCEPTION: database probably overloaded or unreadable.") (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) - (print "exn=" (condition->list exn)) + (debug:print 5 *default-log-port* "exn=" (condition->list exn)) (debug:print 0 *default-log-port* " status: " ((condition-property-accessor 'sqlite3 'status) exn)) (print-call-chain (current-error-port)) (thread-sleep! sleep-time) (debug:print-info 0 *default-log-port* "trying db call one more time....this may never recover, if necessary kill process " (current-process-id) " on host " (get-host-name) " to clean up"))) (apply open-run-close-exception-handling proc idb params)) (apply open-run-close-no-exception-handling proc idb params))) ;; (define open-run-close -(define open-run-close open-run-close-exception-handling) +#;(define open-run-close open-run-close-exception-handling) ;; open-run-close-no-exception-handling ;; open-run-close-exception-handling) ;;) + +(define db:trigger-list + (list (list "update_runs_trigger" "CREATE TRIGGER IF NOT EXISTS update_runs_trigger AFTER UPDATE ON runs + FOR EACH ROW + BEGIN + UPDATE runs SET last_update=(strftime('%s','now')) + WHERE id=old.id; + END;" ) + (list "update_run_stats_trigger" "CREATE TRIGGER IF NOT EXISTS update_run_stats_trigger AFTER UPDATE ON run_stats + FOR EACH ROW + BEGIN + UPDATE run_stats SET last_update=(strftime('%s','now')) + WHERE id=old.id; + END;" ) + (list "update_tests_trigger" "CREATE TRIGGER IF NOT EXISTS update_tests_trigger AFTER UPDATE ON tests + FOR EACH ROW + BEGIN + UPDATE tests SET last_update=(strftime('%s','now')) + WHERE id=old.id; + END;" ) + (list "update_teststeps_trigger" "CREATE TRIGGER IF NOT EXISTS update_teststeps_trigger AFTER UPDATE ON test_steps + FOR EACH ROW + BEGIN + UPDATE test_steps SET last_update=(strftime('%s','now')) + WHERE id=old.id; + END;" ) + (list "update_test_data_trigger" "CREATE TRIGGER IF NOT EXISTS update_test_data_trigger AFTER UPDATE ON test_data + FOR EACH ROW + BEGIN + UPDATE test_data SET last_update=(strftime('%s','now')) + WHERE id=old.id; + END;" ))) + +(define (db:create-all-triggers dbstruct) +(db:with-db + dbstruct #f #f + (lambda (db) +(db:create-triggers db)))) + +(define (db:create-triggers db) + (for-each (lambda (key) + (sqlite3:execute db (cadr key))) + db:trigger-list)) + +(define (db:drop-all-triggers dbstruct) + (db:with-db + dbstruct #f #f + (lambda (db) + (db:drop-triggers db)))) + +(define (db:is-trigger-dropped db tbl-name) + (let* ((trigger-name (if (equal? tbl-name "test_steps") + "update_teststeps_trigger" + (conc "update_" tbl-name "_trigger"))) + (res #f)) + (sqlite3:for-each-row + (lambda (name) + (if (equal? name trigger-name) + (set! res #t))) + db + "SELECT name FROM sqlite_master WHERE type = 'trigger' ;" + ))) + +(define (db:drop-triggers db) + (for-each + (lambda (key) + (sqlite3:execute db (conc "drop trigger if exists " (car key)))) + db:trigger-list)) + +(define (db:drop-trigger db tbl-name) + (let* ((trigger-name (if (equal? tbl-name "test_steps") + "update_teststeps_trigger" + (conc "update_" tbl-name "_trigger")))) + (for-each + (lambda (key) + (if (equal? (car key) trigger-name) + (sqlite3:execute db (conc "drop trigger if exists " trigger-name)))) + db:trigger-list))) + +(define (db:create-trigger db tbl-name) + (let* ((trigger-name (if (equal? tbl-name "test_steps") + "update_teststeps_trigger" + (conc "update_" tbl-name "_trigger")))) + (for-each (lambda (key) + (if (equal? (car key) trigger-name) + (sqlite3:execute db (cadr key)))) + db:trigger-list))) + (define (db:initialize-main-db dbdat) + (when (not *configinfo*) + (launch:setup)) ;; added because Elena was getting stack dump because *configinfo* below was #f. (let* ((configdat (car *configinfo*)) ;; tut tut, global warning... (keys (keys:config-get-fields configdat)) (havekeys (> (length keys) 0)) (keystr (keys->keystr keys)) - (fieldstr (keys->key/field keys)) + (fieldstr (keys:make-key/field-string configdat)) (db (db:dbdat-get-db dbdat))) (for-each (lambda (key) (let ((keyn key)) (if (member (string-downcase keyn) (list "runname" "state" "status" "owner" "event_time" "comment" "fail_count" - "pass_count")) + "pass_count" "contour")) (begin (print "ERROR: your key cannot be named " keyn " as this conflicts with the same named field in the runs table, you must remove your megatest.db and /.db before trying again.") (exit 1))))) keys) (sqlite3:with-transaction db (lambda () - (sqlite3:execute db "CREATE TABLE IF NOT EXISTS keys (id INTEGER PRIMARY KEY, fieldname TEXT, fieldtype TEXT, CONSTRAINT keyconstraint UNIQUE (fieldname));") - (for-each (lambda (key) - (sqlite3:execute db "INSERT OR REPLACE INTO keys (fieldname,fieldtype) VALUES (?,?);" key "TEXT")) - keys) - (sqlite3:execute db (conc - "CREATE TABLE IF NOT EXISTS runs (id INTEGER PRIMARY KEY, \n " - fieldstr (if havekeys "," "") " + ;; handle-exceptions + ;; exn + ;; (begin + ;; (debug:print 0 "ERROR: Failed to create tables. Look at your [fields] section, should be: fieldname TEXT DEFAULT 'yourdefault'") + ;; (exit)) + (sqlite3:execute db "CREATE TABLE IF NOT EXISTS keys (id INTEGER PRIMARY KEY, fieldname TEXT, fieldtype TEXT, CONSTRAINT keyconstraint UNIQUE (fieldname));") + (for-each (lambda (key) + (sqlite3:execute db "INSERT OR REPLACE INTO keys (fieldname,fieldtype) VALUES (?,?);" key "TEXT")) + keys) + (sqlite3:execute db (conc + "CREATE TABLE IF NOT EXISTS runs (id INTEGER PRIMARY KEY, \n " + fieldstr (if havekeys "," "") " runname TEXT DEFAULT 'norun', + contour TEXT DEFAULT '', state TEXT DEFAULT '', status TEXT DEFAULT '', owner TEXT DEFAULT '', event_time TIMESTAMP DEFAULT (strftime('%s','now')), comment TEXT DEFAULT '', fail_count INTEGER DEFAULT 0, pass_count INTEGER DEFAULT 0, last_update INTEGER DEFAULT (strftime('%s','now')), CONSTRAINT runsconstraint UNIQUE (runname" (if havekeys "," "") keystr "));")) - (sqlite3:execute db "CREATE TRIGGER IF NOT EXISTS update_runs_trigger AFTER UPDATE ON runs - FOR EACH ROW - BEGIN - UPDATE runs SET last_update=(strftime('%s','now')) - WHERE id=old.id; - END;") - (sqlite3:execute db "CREATE TABLE IF NOT EXISTS run_stats ( + ;; All triggers created at once in end + ;;(sqlite3:execute db "CREATE TRIGGER IF NOT EXISTS update_runs_trigger AFTER UPDATE ON runs + ;; FOR EACH ROW + ;; BEGIN + ;; UPDATE runs SET last_update=(strftime('%s','now')) + ;; WHERE id=old.id; + ;; END;") + (sqlite3:execute db "CREATE TABLE IF NOT EXISTS run_stats ( id INTEGER PRIMARY KEY, run_id INTEGER, state TEXT, status TEXT, count INTEGER, last_update INTEGER DEFAULT (strftime('%s','now')))") - (sqlite3:execute db "CREATE TRIGGER IF NOT EXISTS update_run_stats_trigger AFTER UPDATE ON run_stats - FOR EACH ROW - BEGIN - UPDATE run_stats SET last_update=(strftime('%s','now')) - WHERE id=old.id; - END;") - (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_meta ( + ;; All triggers created at once in end + ;; (sqlite3:execute db "CREATE TRIGGER IF NOT EXISTS update_run_stats_trigger AFTER UPDATE ON run_stats + ;; FOR EACH ROW + ;; BEGIN + ;; UPDATE run_stats SET last_update=(strftime('%s','now')) + ;; WHERE id=old.id; + ;; END;") + (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_meta ( id INTEGER PRIMARY KEY, testname TEXT DEFAULT '', author TEXT DEFAULT '', owner TEXT DEFAULT '', description TEXT DEFAULT '', @@ -969,11 +1384,11 @@ avg_runtime REAL, avg_disk REAL, tags TEXT DEFAULT '', jobgroup TEXT DEFAULT 'default', CONSTRAINT test_meta_constraint UNIQUE (testname));") - (sqlite3:execute db "CREATE TABLE IF NOT EXISTS tasks_queue (id INTEGER PRIMARY KEY, + (sqlite3:execute db "CREATE TABLE IF NOT EXISTS tasks_queue (id INTEGER PRIMARY KEY, action TEXT DEFAULT '', owner TEXT, state TEXT DEFAULT 'new', target TEXT DEFAULT '', name TEXT DEFAULT '', @@ -980,57 +1395,57 @@ testpatt TEXT DEFAULT '', keylock TEXT, params TEXT, creation_time TIMESTAMP DEFAULT (strftime('%s','now')), execution_time TIMESTAMP);") - ;; archive disk areas, cached info from [archive-disks] - (sqlite3:execute db "CREATE TABLE IF NOT EXISTS archive_disks ( + ;; archive disk areas, cached info from [archive-disks] + (sqlite3:execute db "CREATE TABLE IF NOT EXISTS archive_disks ( id INTEGER PRIMARY KEY, archive_area_name TEXT, disk_path TEXT, last_df INTEGER DEFAULT -1, last_df_time TIMESTAMP DEFAULT (strftime('%s','now')), - creation_time TIMESTAMP DEFAULT (strftime('%','now')));") - ;; individual bup (or tar) data chunks - (sqlite3:execute db "CREATE TABLE IF NOT EXISTS archive_blocks ( + creation_time TIMESTAMP DEFAULT (strftime('%s','now')));") + ;; individual bup (or tar) data chunks + (sqlite3:execute db "CREATE TABLE IF NOT EXISTS archive_blocks ( id INTEGER PRIMARY KEY, archive_disk_id INTEGER, disk_path TEXT, last_du INTEGER DEFAULT -1, last_du_time TIMESTAMP DEFAULT (strftime('%s','now')), - creation_time TIMESTAMP DEFAULT (strftime('%','now')));") - ;; tests allocated to what chunks. reusing a chunk for a test/item_path is very efficient - ;; NB// the per run/test recording of where the archive is stored is done in the test - ;; record. - (sqlite3:execute db "CREATE TABLE IF NOT EXISTS archive_allocations ( + creation_time TIMESTAMP DEFAULT (strftime('%s','now')));") + ;; tests allocated to what chunks. reusing a chunk for a test/item_path is very efficient + ;; NB// the per run/test recording of where the archive is stored is done in the test + ;; record. + (sqlite3:execute db "CREATE TABLE IF NOT EXISTS archive_allocations ( id INTEGER PRIMARY KEY, archive_block_id INTEGER, testname TEXT, item_path TEXT, - creation_time TIMESTAMP DEFAULT (strftime('%','now')));") - ;; move this clean up call somewhere else - (sqlite3:execute db "DELETE FROM tasks_queue WHERE state='done' AND creation_time < ?;" (- (current-seconds)(* 24 60 60))) ;; remove older than 24 hrs - (sqlite3:execute db (conc "CREATE INDEX IF NOT EXISTS runs_index ON runs (runname" (if havekeys "," "") keystr ");")) - ;; (sqlite3:execute db "CREATE VIEW runs_tests AS SELECT * FROM runs INNER JOIN tests ON runs.id=tests.run_id;") - (sqlite3:execute db "CREATE TABLE IF NOT EXISTS extradat (id INTEGER PRIMARY KEY, run_id INTEGER, key TEXT, val TEXT);") - (sqlite3:execute db "CREATE TABLE IF NOT EXISTS metadat (id INTEGER PRIMARY KEY, var TEXT, val TEXT, + creation_time TIMESTAMP DEFAULT (strftime('%s','now')));") + ;; move this clean up call somewhere else + (sqlite3:execute db "DELETE FROM tasks_queue WHERE state='done' AND creation_time < ?;" (- (current-seconds)(* 24 60 60))) ;; remove older than 24 hrs + (sqlite3:execute db (conc "CREATE INDEX IF NOT EXISTS runs_index ON runs (runname" (if havekeys "," "") keystr ");")) + ;; (sqlite3:execute db "CREATE VIEW runs_tests AS SELECT * FROM runs INNER JOIN tests ON runs.id=tests.run_id;") + (sqlite3:execute db "CREATE TABLE IF NOT EXISTS extradat (id INTEGER PRIMARY KEY, run_id INTEGER, key TEXT, val TEXT);") + (sqlite3:execute db "CREATE TABLE IF NOT EXISTS metadat (id INTEGER PRIMARY KEY, var TEXT, val TEXT, CONSTRAINT metadat_constraint UNIQUE (var));") - (sqlite3:execute db "CREATE TABLE IF NOT EXISTS access_log (id INTEGER PRIMARY KEY, user TEXT, accessed TIMESTAMP, args TEXT);") - ;; Must do this *after* running patch db !! No more. - ;; cannot use db:set-var since it will deadlock, hardwire the code here - (sqlite3:execute db "INSERT OR REPLACE INTO metadat (var,val) VALUES (?,?);" "MEGATEST_VERSION" (common:version-signature)) - (debug:print-info 11 *default-log-port* "db:initialize END"))))) - -;;====================================================================== -;; R U N S P E C I F I C D B -;;====================================================================== - -(define (db:initialize-run-id-db db) - (sqlite3:with-transaction - db - (lambda () - (sqlite3:execute db "CREATE TABLE IF NOT EXISTS tests + (sqlite3:execute db "CREATE TABLE IF NOT EXISTS access_log (id INTEGER PRIMARY KEY, user TEXT, accessed TIMESTAMP, args TEXT);") + ;; Must do this *after* running patch db !! No more. + ;; cannot use db:set-var since it will deadlock, hardwire the code here + (sqlite3:execute db "INSERT OR REPLACE INTO metadat (var,val) VALUES (?,?);" "MEGATEST_VERSION" (common:version-signature)) + (debug:print-info 11 *default-log-port* "db:initialize END") ;; )))) + + ;;====================================================================== + ;; R U N S P E C I F I C D B + ;;====================================================================== + + ;; (define (db:initialize-run-id-db db) + ;; (sqlite3:with-transaction + ;; db + ;; (lambda () + (sqlite3:execute db "CREATE TABLE IF NOT EXISTS tests (id INTEGER PRIMARY KEY, run_id INTEGER DEFAULT -1, testname TEXT DEFAULT 'noname', host TEXT DEFAULT 'n/a', cpuload REAL DEFAULT -1, @@ -1050,18 +1465,24 @@ fail_count INTEGER DEFAULT 0, pass_count INTEGER DEFAULT 0, archived INTEGER DEFAULT 0, -- 0=no, > 1=archive block id where test data can be found last_update INTEGER DEFAULT (strftime('%s','now')), CONSTRAINT testsconstraint UNIQUE (run_id, testname, item_path));") - (sqlite3:execute db "CREATE INDEX IF NOT EXISTS tests_index ON tests (run_id, testname, item_path);") - (sqlite3:execute db "CREATE TRIGGER IF NOT EXISTS update_tests_trigger AFTER UPDATE ON tests - FOR EACH ROW - BEGIN - UPDATE tests SET last_update=(strftime('%s','now')) - WHERE id=old.id; - END;") - (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_steps + ;; deprecated -- (sqlite3:execute db "CREATE INDEX IF NOT EXISTS tests_index ON tests (run_id, testname, item_path, uname);") + + (sqlite3:execute db "CREATE INDEX IF NOT EXISTS tests_run_id_index ON tests (run_id);") ;; new + (sqlite3:execute db "CREATE INDEX IF NOT EXISTS tests_testname_index ON tests (testname,item_path);") ;; new + (sqlite3:execute db "CREATE INDEX IF NOT EXISTS tests_state_status_index ON tests (state, status); ") ;; new + + ;; All triggers created at once in end + ;;(sqlite3:execute db "CREATE TRIGGER IF NOT EXISTS update_tests_trigger AFTER UPDATE ON tests + ;; FOR EACH ROW + ;; BEGIN + ;; UPDATE tests SET last_update=(strftime('%s','now')) + ;; WHERE id=old.id; + ;; END;") + (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_steps (id INTEGER PRIMARY KEY, test_id INTEGER, stepname TEXT, state TEXT DEFAULT 'NOT_STARTED', status TEXT DEFAULT 'n/a', @@ -1068,18 +1489,19 @@ event_time TIMESTAMP, comment TEXT DEFAULT '', logfile TEXT DEFAULT '', last_update INTEGER DEFAULT (strftime('%s','now')), CONSTRAINT test_steps_constraint UNIQUE (test_id,stepname,state));") - (sqlite3:execute db "CREATE INDEX IF NOT EXISTS teststeps_index ON tests (run_id, testname, item_path);") - (sqlite3:execute db "CREATE TRIGGER IF NOT EXISTS update_teststeps_trigger AFTER UPDATE ON test_steps - FOR EACH ROW - BEGIN - UPDATE test_steps SET last_update=(strftime('%s','now')) - WHERE id=old.id; - END;") - (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_data (id INTEGER PRIMARY KEY, + (sqlite3:execute db "CREATE INDEX IF NOT EXISTS teststeps_index ON tests (run_id, testname, item_path);") + ;; All triggers created at once in end + ;;(sqlite3:execute db "CREATE TRIGGER IF NOT EXISTS update_teststeps_trigger AFTER UPDATE ON test_steps + ;; FOR EACH ROW + ;; BEGIN + ;; UPDATE test_steps SET last_update=(strftime('%s','now')) + ;; WHERE id=old.id; + ;; END;") + (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_data (id INTEGER PRIMARY KEY, test_id INTEGER, category TEXT DEFAULT '', variable TEXT, value REAL, expected REAL, @@ -1088,34 +1510,36 @@ comment TEXT DEFAULT '', status TEXT DEFAULT 'n/a', type TEXT DEFAULT '', last_update INTEGER DEFAULT (strftime('%s','now')), CONSTRAINT test_data_constraint UNIQUE (test_id,category,variable));") - (sqlite3:execute db "CREATE INDEX IF NOT EXISTS test_data_index ON test_data (test_id);") - (sqlite3:execute db "CREATE TRIGGER IF NOT EXISTS update_test_data_trigger AFTER UPDATE ON test_data - FOR EACH ROW - BEGIN - UPDATE test_data SET last_update=(strftime('%s','now')) - WHERE id=old.id; - END;") - (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_rundat ( + (sqlite3:execute db "CREATE INDEX IF NOT EXISTS test_data_index ON test_data (test_id);") + ;; All triggers created at once in end + ;;(sqlite3:execute db "CREATE TRIGGER IF NOT EXISTS update_test_data_trigger AFTER UPDATE ON test_data + ;; FOR EACH ROW + ;; BEGIN + ;; UPDATE test_data SET last_update=(strftime('%s','now')) + ;; WHERE id=old.id; + ;; END;") + (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_rundat ( id INTEGER PRIMARY KEY, test_id INTEGER, update_time TIMESTAMP, cpuload INTEGER DEFAULT -1, diskfree INTEGER DEFAULT -1, diskusage INTGER DEFAULT -1, run_duration INTEGER DEFAULT 0);") - (sqlite3:execute db "CREATE TABLE IF NOT EXISTS archives ( + (sqlite3:execute db "CREATE TABLE IF NOT EXISTS archives ( id INTEGER PRIMARY KEY, test_id INTEGER, state TEXT DEFAULT 'new', status TEXT DEFAULT 'n/a', archive_type TEXT DEFAULT 'bup', du INTEGER, archive_path TEXT);"))) - db) + (db:create-triggers db) + db)) ;; ) ;;====================================================================== ;; A R C H I V E S ;;====================================================================== @@ -1122,11 +1546,11 @@ ;; dneeded is minimum space needed, scan for existing archives that ;; are on disks with adequate space and already have this test/itempath ;; archived ;; (define (db:archive-get-allocations dbstruct testname itempath dneeded) - (let* ((dbdat (db:get-db dbstruct #f)) ;; archive tables are in main.db + (let* ((dbdat (db:get-db dbstruct)) ;; archive tables are in main.db (db (db:dbdat-get-db dbdat)) (res '()) (blocks '())) ;; a block is an archive chunck that can be added too if there is space (sqlite3:for-each-row (lambda (id archive-disk-id disk-path last-du last-du-time) @@ -1147,17 +1571,18 @@ "SELECT d.id,d.archive_area_name,disk_path,last_df,last_df_time FROM archive_disks AS d INNER JOIN archive_blocks AS b ON d.id=b.archive_disk_id WHERE b.id IN (" (string-intersperse (map conc res) ",") ") AND last_df > ?;") dneeded)) + (stack-push! (dbr:dbstruct-dbstack dbstruct) dbdat) blocks)) ;; returns id of the record, register a disk allocated to archiving and record it's last known ;; available space ;; (define (db:archive-register-disk dbstruct bdisk-name bdisk-path df) - (let* ((dbdat (db:get-db dbstruct #f)) ;; archive tables are in main.db + (let* ((dbdat (db:get-db dbstruct)) ;; archive tables are in main.db (db (db:dbdat-get-db dbdat)) (res #f)) (sqlite3:for-each-row (lambda (id) (set! res id)) @@ -1167,25 +1592,27 @@ (if res ;; record exists, update df and return id (begin (sqlite3:execute db "UPDATE archive_disks SET last_df=?,last_df_time=(strftime('%s','now')) WHERE archive_area_name=? AND disk_path=?;" df bdisk-name bdisk-path) + (stack-push! (dbr:dbstruct-dbstack dbstruct) dbdat) res) (begin (sqlite3:execute db "INSERT OR REPLACE INTO archive_disks (archive_area_name,disk_path,last_df) VALUES (?,?,?);" bdisk-name bdisk-path df) + (stack-push! (dbr:dbstruct-dbstack dbstruct) dbdat) (db:archive-register-disk dbstruct bdisk-name bdisk-path df))))) ;; record an archive path created on a given archive disk (identified by it's bdisk-id) ;; if path starts with / then it is full, otherwise it is relative to the archive disk ;; preference is to store the relative path. ;; (define (db:archive-register-block-name dbstruct bdisk-id archive-path #!key (du #f)) - (let* ((dbdat (db:get-db dbstruct #f)) ;; archive tables are in main.db + (let* ((dbdat (db:get-db dbstruct)) ;; archive tables are in main.db (db (db:dbdat-get-db dbdat)) (res #f)) ;; first look to see if this path is already registered (sqlite3:for-each-row (lambda (id) @@ -1192,20 +1619,20 @@ (set! res id)) db "SELECT id FROM archive_blocks WHERE archive_disk_id=? AND disk_path=?;" bdisk-id archive-path) (if res ;; record exists, update du if applicable and return res - (begin - (if du (sqlite3:exectute db "UPDATE archive_blocks SET last_du=?,last_du_time=(strftime('%s','now')) + (if du (sqlite3:execute db "UPDATE archive_blocks SET last_du=?,last_du_time=(strftime('%s','now')) WHERE archive_disk_id=? AND disk_path=?;" - bdisk-id archive-path du)) - res) + bdisk-id archive-path du)) (begin (sqlite3:execute db "INSERT OR REPLACE INTO archive_blocks (archive_disk_id,disk_path,last_du) VALUES (?,?,?);" bdisk-id archive-path (or du 0)) - (db:archive-register-block-name dbstruct bdisk-id archive-path du: du))))) + (set! res (db:archive-register-block-name dbstruct bdisk-id archive-path du: du)))) + (stack-push! (dbr:dbstruct-dbstack dbstruct) dbdat) + res)) ;; The "archived" field in tests is overloaded; 0 = not archived, > 0 archived in block with given id ;; (define (db:test-set-archive-block-id dbstruct run-id test-id archive-block-id) @@ -1244,15 +1671,15 @@ ;;====================================================================== ;; L O G G I N G D B ;;====================================================================== -(define (open-logging-db) ;; (conc *toppath* "/megatest.db") (car *configinfo*))) +(define (open-logging-db) (let* ((dbpath (conc (if *toppath* (conc *toppath* "/") "") "logging.db")) ;; fname) - (dbexists (file-exists? dbpath)) + (dbexists (common:file-exists? dbpath)) (db (sqlite3:open-database dbpath)) - (handler (make-busy-timeout (if (args:get-arg "-override-timeout") + (handler (sqlite3:make-busy-timeout (if (args:get-arg "-override-timeout") (string->number (args:get-arg "-override-timeout")) 136000)))) ;; 136000))) (sqlite3:set-busy-handler! db handler) (if (not dbexists) (begin @@ -1282,152 +1709,250 @@ ;;====================================================================== ;; M A I N T E N A N C E ;;====================================================================== (define (db:have-incompletes? dbstruct run-id ovr-deadtime) - (let* ((dbdat (db:get-db dbstruct run-id)) - (db (db:dbdat-get-db dbdat)) - (incompleted '()) + (let* ((incompleted '()) (oldlaunched '()) (toplevels '()) (deadtime-str (configf:lookup *configdat* "setup" "deadtime")) (deadtime (if (and deadtime-str (string->number deadtime-str)) (string->number deadtime-str) - 7200))) ;; two hours - (if (number? ovr-deadtime)(set! deadtime ovr-deadtime)) - - ;; in RUNNING or REMOTEHOSTSTART for more than 10 minutes - ;; - ;; HOWEVER: this code in run:test seems to work fine - ;; (> (- (current-seconds)(+ (db:test-get-event_time testdat) - ;; (db:test-get-run_duration testdat))) - ;; 600) - (db:delay-if-busy dbdat) - (sqlite3:for-each-row - (lambda (test-id run-dir uname testname item-path) - (if (and (equal? uname "n/a") - (equal? item-path "")) ;; this is a toplevel test - ;; what to do with toplevel? call rollup? - (begin - (set! toplevels (cons (list test-id run-dir uname testname item-path run-id) toplevels)) - (debug:print-info 0 *default-log-port* "Found old toplevel test in RUNNING state, test-id=" test-id)) - (set! incompleted (cons (list test-id run-dir uname testname item-path run-id) incompleted)))) - db - "SELECT id,rundir,uname,testname,item_path FROM tests WHERE run_id=? AND (strftime('%s','now') - event_time) > (run_duration + ?) AND state IN ('RUNNING','REMOTEHOSTSTART');" - run-id deadtime) - - ;; in LAUNCHED for more than one day. Could be long due to job queues TODO/BUG: Need override for this in config - ;; - (db:delay-if-busy dbdat) - (sqlite3:for-each-row - (lambda (test-id run-dir uname testname item-path) - (if (and (equal? uname "n/a") - (equal? item-path "")) ;; this is a toplevel test - ;; what to do with toplevel? call rollup? - (set! toplevels (cons (list test-id run-dir uname testname item-path run-id) toplevels)) - (set! oldlaunched (cons (list test-id run-dir uname testname item-path run-id) oldlaunched)))) - db - "SELECT id,rundir,uname,testname,item_path FROM tests WHERE run_id=? AND (strftime('%s','now') - event_time) > 86400 AND state IN ('LAUNCHED');" - run-id) - - (debug:print-info 18 *default-log-port* "Found " (length oldlaunched) " old LAUNCHED items, " (length toplevels) " old LAUNCHED toplevel tests and " (length incompleted) " tests marked RUNNING but apparently dead.") - (if (and (null? incompleted) - (null? oldlaunched) - (null? toplevels)) - #f - #t))) - + 72000))) ;; twenty hours + (db:with-db + dbstruct #f #f + (lambda (db) + (if (number? ovr-deadtime)(set! deadtime ovr-deadtime)) + + ;; in RUNNING or REMOTEHOSTSTART for more than 10 minutes + ;; + ;; HOWEVER: this code in run:test seems to work fine + ;; (> (- (current-seconds)(+ (db:test-get-event_time testdat) + ;; (db:test-get-run_duration testdat))) + ;; 600) + ;; (db:delay-if-busy dbdat) + (sqlite3:for-each-row + (lambda (test-id run-dir uname testname item-path) + (if (and (equal? uname "n/a") + (equal? item-path "")) ;; this is a toplevel test + ;; what to do with toplevel? call rollup? + (begin + (set! toplevels (cons (list test-id run-dir uname testname item-path run-id) toplevels)) + (debug:print-info 0 *default-log-port* "Found old toplevel test in RUNNING state, test-id=" test-id)) + (set! incompleted (cons (list test-id run-dir uname testname item-path run-id) incompleted)))) + db + "SELECT id,rundir,uname,testname,item_path FROM tests WHERE run_id=? AND (strftime('%s','now') - event_time) > (run_duration + ?) AND state IN ('RUNNING','REMOTEHOSTSTART');" + run-id deadtime) + + ;; in LAUNCHED for more than one day. Could be long due to job queues TODO/BUG: Need override for this in config + ;; + ;; (db:delay-if-busy dbdat) + (sqlite3:for-each-row + (lambda (test-id run-dir uname testname item-path) + (if (and (equal? uname "n/a") + (equal? item-path "")) ;; this is a toplevel test + ;; what to do with toplevel? call rollup? + (set! toplevels (cons (list test-id run-dir uname testname item-path run-id) toplevels)) + (set! oldlaunched (cons (list test-id run-dir uname testname item-path run-id) oldlaunched)))) + db + "SELECT id,rundir,uname,testname,item_path FROM tests WHERE run_id=? AND (strftime('%s','now') - event_time) > 86400 AND state IN ('LAUNCHED');" + run-id) + + (debug:print-info 18 *default-log-port* "Found " (length oldlaunched) " old LAUNCHED items, " (length toplevels) " old LAUNCHED toplevel tests and " (length incompleted) " tests marked RUNNING but apparently dead.") + (if (and (null? incompleted) + (null? oldlaunched) + (null? toplevels)) + #f + #t))))) + +(define (db:get-status-from-final-status-file run-dir) + (let ((infile (conc run-dir "/.final-status"))) + ;; first verify we are able to write the output file + (if (not (file-read-access? infile)) + (begin + (debug:print 0 *default-log-port* "ERROR: cannot read " infile) + (debug:print 0 *default-log-port* "ERROR: run-dir is " run-dir) + #f + ) + (with-input-from-file infile read-lines) + ))) + +;; check duration against test-run.dat file if it exists and update the value in +;; the db if necessary +;; +(define (db:adjust-run-duration dbstruct test-id run-dir event-time run-duration) + (let* ((datf (conc run-dir ".mt_data/test-run.dat")) + (modt (if (and (file-exists? datf) + (file-read-access? datf)) + (file-modification-time datf) + #f)) ;; (+ event-time run-duration)))) + (alt-run-duration (if modt + (- modt event-time) + #f))) + (if (and alt-run-duration + (> alt-run-duration run-duration)) + (begin + (debug:print 0 *default-log-port* "Test " test-id " run duration mismatch. Setting to " alt-run-duration) + (db:with-db + dbstruct #f #f + (lambda (db) + (sqlite3:execute db "UPDATE tests SET run_duration=? WHERE id=?;" alt-run-duration test-id) + #t))) + #f))) ;; #f = we did NOT adjust the time + ;; select end_time-now from ;; (select testname,item_path,event_time+run_duration as ;; end_time,strftime('%s','now') as now from tests where state in -;; ('RUNNING','REMOTEHOSTSTART','LAUNCED')); +;; ('RUNNING','REMOTEHOSTSTART','LAUNCHED')); (define (db:find-and-mark-incomplete dbstruct run-id ovr-deadtime) - (let* ((dbdat (db:get-db dbstruct run-id)) - (db (db:dbdat-get-db dbdat)) - (incompleted '()) + (let* ((incompleted '()) (oldlaunched '()) (toplevels '()) - (deadtime-str (configf:lookup *configdat* "setup" "deadtime")) - (deadtime (if (and deadtime-str - (string->number deadtime-str)) - (string->number deadtime-str) - 7200))) ;; two hours - (if (number? ovr-deadtime)(set! deadtime ovr-deadtime)) - - ;; in RUNNING or REMOTEHOSTSTART for more than 10 minutes - ;; - ;; HOWEVER: this code in run:test seems to work fine - ;; (> (- (current-seconds)(+ (db:test-get-event_time testdat) - ;; (db:test-get-run_duration testdat))) - ;; 600) - (db:delay-if-busy dbdat) - (sqlite3:for-each-row - (lambda (test-id run-dir uname testname item-path) - (if (and (equal? uname "n/a") - (equal? item-path "")) ;; this is a toplevel test - ;; what to do with toplevel? call rollup? - (begin - (set! toplevels (cons (list test-id run-dir uname testname item-path run-id) toplevels)) - (debug:print-info 0 *default-log-port* "Found old toplevel test in RUNNING state, test-id=" test-id)) - (set! incompleted (cons (list test-id run-dir uname testname item-path run-id) incompleted)))) - db - "SELECT id,rundir,uname,testname,item_path FROM tests WHERE run_id=? AND (strftime('%s','now') - event_time) > (run_duration + ?) AND state IN ('RUNNING','REMOTEHOSTSTART');" - run-id deadtime) - - ;; in LAUNCHED for more than one day. Could be long due to job queues TODO/BUG: Need override for this in config - ;; - (db:delay-if-busy dbdat) - (sqlite3:for-each-row - (lambda (test-id run-dir uname testname item-path) - (if (and (equal? uname "n/a") - (equal? item-path "")) ;; this is a toplevel test - ;; what to do with toplevel? call rollup? - (set! toplevels (cons (list test-id run-dir uname testname item-path run-id) toplevels)) - (set! oldlaunched (cons (list test-id run-dir uname testname item-path run-id) oldlaunched)))) - db - "SELECT id,rundir,uname,testname,item_path FROM tests WHERE run_id=? AND (strftime('%s','now') - event_time) > 86400 AND state IN ('LAUNCHED');" - run-id) - - (debug:print-info 18 *default-log-port* "Found " (length oldlaunched) " old LAUNCHED items, " (length toplevels) " old LAUNCHED toplevel tests and " (length incompleted) " tests marked RUNNING but apparently dead.") - - ;; These are defunct tests, do not do all the overhead of set-state-status. Force them to INCOMPLETE. - ;; - (db:delay-if-busy dbdat) - (let* (;; (min-incompleted (filter (lambda (x) - ;; (let* ((testpath (cadr x)) - ;; (tdatpath (conc testpath "/testdat.db")) - ;; (dbexists (file-exists? tdatpath))) - ;; (or (not dbexists) ;; if no file then something wrong - mark as incomplete - ;; (> (- (current-seconds)(file-modification-time tdatpath)) 600)))) ;; no change in 10 minutes to testdat.db - she's dead Jim - ;; incompleted)) - (min-incompleted-ids (map car incompleted)) ;; do 'em all - (all-ids (append min-incompleted-ids (map car oldlaunched)))) - (if (> (length all-ids) 0) - (begin - (debug:print 0 *default-log-port* "WARNING: Marking test(s); " (string-intersperse (map conc all-ids) ", ") " as INCOMPLETE") - (sqlite3:execute - db - (conc "UPDATE tests SET state='INCOMPLETE' WHERE id IN (" - (string-intersperse (map conc all-ids) ",") - ");"))))) - - ;; Now do rollups for the toplevel tests - ;; - (db:delay-if-busy dbdat) - (for-each - (lambda (toptest) - (let ((test-name (list-ref toptest 3))) -;; (run-id (list-ref toptest 5))) - (db:top-test-set-per-pf-counts dbstruct run-id test-name))) - toplevels))) - + ;; The default running-deadtime is 720 seconds = 12 minutes. + ;; "(running-deadtime-default (+ server-start-allowance (* 2 launch-monitor-period)))" = 200 + (2 * (200 + 30 + 30)) + (deadtime-trim (or ovr-deadtime (configf:lookup-number *configdat* "setup" "deadtime"))) + (server-start-allowance 200) + (server-overloaded-budget 200) + (launch-monitor-off-time (or (configf:lookup-number *configdat* "setup" "test-stats-update-period") 30)) + (launch-monitor-on-time-budget 30) + (launch-monitor-period (+ launch-monitor-off-time launch-monitor-on-time-budget server-overloaded-budget)) + (remotehoststart-deadtime-default (+ server-start-allowance server-overloaded-budget 30)) + (remotehoststart-deadtime (or deadtime-trim remotehoststart-deadtime-default)) + (running-deadtime-default (+ server-start-allowance (* 2 launch-monitor-period))) + (running-deadtime (or deadtime-trim running-deadtime-default)) ;; two minutes (30 seconds between updates, this leaves 3x grace period) + ) + (debug:print-info 4 *default-log-port* "running-deadtime = " running-deadtime) + (debug:print-info 4 *default-log-port* "deadtime-trim = " deadtime-trim) + + (db:with-db + dbstruct #f #f + (lambda (db) + (let* ((stmth1 (db:get-cache-stmth + dbstruct db + "SELECT id,rundir,uname,testname,item_path,event_time,run_duration FROM tests + WHERE run_id=? AND (strftime('%s','now') - event_time) > (run_duration + ?) + AND state IN ('RUNNING');")) + (stmth2 (db:get-cache-stmth + dbstruct db + "SELECT id,rundir,uname,testname,item_path,event_time,run_duration FROM tests + WHERE run_id=? AND (strftime('%s','now') - event_time) > (run_duration + ?) + AND state IN ('REMOTEHOSTSTART');")) + (stmth3 (db:get-cache-stmth + dbstruct db + "SELECT id,rundir,uname,testname,item_path FROM tests + WHERE run_id=? AND (strftime('%s','now') - event_time) > 86400 + AND state IN ('LAUNCHED');"))) + ;; in RUNNING or REMOTEHOSTSTART for more than 10 minutes + ;; + ;; HOWEVER: this code in run:test seems to work fine + ;; (> (- (current-seconds)(+ (db:test-get-event_time testdat) + ;; (db:test-get-run_duration testdat))) + ;; 600) + ;; (db:delay-if-busy dbdat) + (sqlite3:for-each-row + (lambda (test-id run-dir uname testname item-path event-time run-duration) + (if (not (db:adjust-run-duration dbstruct test-id run-dir event-time run-duration)) + (if (and (equal? uname "n/a") + (equal? item-path "")) ;; this is a toplevel test + ;; what to do with toplevel? call rollup? + (begin + (set! toplevels (cons (list test-id run-dir uname testname item-path run-id) toplevels)) + (debug:print-info 0 *default-log-port* "Found old toplevel test in RUNNING state, test-id=" test-id)) + (begin + (set! incompleted (cons (list test-id run-dir uname testname item-path run-id) incompleted)) + (debug:print-info 0 *default-log-port* "Found old test in RUNNING state, test-id=" + test-id" exceeded running-deadtime "running-deadtime" now="(current-seconds) + " event-time="event-time" run-duration="run-duration))))) + stmth1 + run-id running-deadtime) ;; default time 720 seconds + + (sqlite3:for-each-row + (lambda (test-id run-dir uname testname item-path event-time run-duration) + (if (not (db:adjust-run-duration dbstruct test-id run-dir event-time run-duration)) + (if (and (equal? uname "n/a") + (equal? item-path "")) ;; this is a toplevel test + ;; what to do with toplevel? call rollup? + (begin + (set! toplevels (cons (list test-id run-dir uname testname item-path run-id) toplevels)) + (debug:print-info 0 *default-log-port* "Found old toplevel test in RUNNING state, test-id=" test-id)) + (begin + (debug:print-info 0 *default-log-port* "Found old test in REMOTEHOSTSTART state, test-id=" test-id + " exceeded running-deadtime "running-deadtime" now="(current-seconds)" event-time="event-time + " run-duration="run-duration) + (set! incompleted (cons (list test-id run-dir uname testname item-path run-id) incompleted)))))) + stmth2 + run-id remotehoststart-deadtime) ;; default time 230 seconds + + ;; in LAUNCHED for more than one day. Could be long due to job queues TODO/BUG: Need override for this in config + ;; + ;; (db:delay-if-busy dbdat) + (sqlite3:for-each-row + (lambda (test-id run-dir uname testname item-path) + (if (and (equal? uname "n/a") + (equal? item-path "")) ;; this is a toplevel test + ;; what to do with toplevel? call rollup? + (set! toplevels (cons (list test-id run-dir uname testname item-path run-id) toplevels)) + (begin + (debug:print-info 0 *default-log-port* "Found old test in LAUNCHED state, test-id=" test-id + " 1 day since event_time marked") + (set! oldlaunched (cons (list test-id run-dir uname testname item-path run-id) oldlaunched))))) + stmth3 + run-id) + + (debug:print-info 18 *default-log-port* "Found " (length oldlaunched) " old LAUNCHED items, " + (length toplevels) " old LAUNCHED toplevel tests and " + (length incompleted) " tests marked RUNNING but apparently dead.")) + + ;; These are defunct tests, do not do all the overhead of set-state-status. Force them to INCOMPLETE. + ;; + ;; (db:delay-if-busy dbdat) + (let* ((min-incompleted-ids (map car incompleted)) ;; do 'em all + (all-ids (append min-incompleted-ids (map car oldlaunched)))) + (if (> (length all-ids) 0) + (begin + ;; (launch:is-test-alive "localhost" 435) + (debug:print 0 *default-log-port* "WARNING: Marking test(s); " (string-intersperse (map conc all-ids) ", ") + " as DEAD") + (for-each + (lambda (test-id) + (let* (;; (run-dir (db:test-get-rundir-from-test-id dbstruct run-id test-id)) + (tinfo (db:get-test-info-by-id dbstruct run-id test-id)) + (run-dir (db:test-get-rundir tinfo)) + (host (db:test-get-host tinfo)) + (pid (db:test-get-process_id tinfo)) + (result (db:get-status-from-final-status-file run-dir))) + (if (and (list? result) (> (length result) 1) (equal? "PASS" (cadr result)) (equal? "COMPLETED" (car result))) + (begin + (debug:print 0 *default-log-port* "INFO: test " test-id " actually passed, so marking PASS not DEAD") + (db:set-state-status-and-roll-up-items + dbstruct run-id test-id 'foo "COMPLETED" "PASS" + "Test stopped responding but it has PASSED; marking it PASS in the DB.")) + (let ((is-alive (and (not (eq? pid 0)) ;; 0 is default in re-used field "attemptnum" where pid stored. + (launch:is-test-alive host pid)))) + (if is-alive + (debug:print 0 *default-log-port* "INFO: test " test-id " on host " host + " has a process on pid " pid ", NOT setting to DEAD.") + (begin + (debug:print 0 *default-log-port* "INFO: test " test-id + " final state/status is not COMPLETED/PASS. It is " result) + (db:set-state-status-and-roll-up-items + dbstruct run-id test-id 'foo "COMPLETED" "DEAD" + "Test stopped responding while in RUNNING or REMOTEHOSTSTART; presumed dead."))))))) + ;; call end of eud of run detection for posthook - from merge, is it needed? + ;; (launch:end-of-run-check run-id) + all-ids) + ;;call end of eud of run detection for posthook + (launch:end-of-run-check run-id) + ))))))) + +;; BUG: Probably broken - does not explicitly use run-id in the query +;; (define (db:top-test-set-per-pf-counts dbstruct run-id test-name) - (db:general-call (db:get-db dbstruct run-id) 'top-test-set-per-pf-counts (list test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name))) - - + (db:general-call dbstruct 'top-test-set-per-pf-counts (list test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name))) + ;; Clean out old junk and vacuum the database ;; ;; Ultimately do something like this: ;; ;; 1. Look at test records either deleted or part of deleted run: @@ -1437,28 +1962,37 @@ ;; a. If have tests that are not deleted, set state='unknown' ;; b. .... ;; (define (db:clean-up dbdat) ;; (debug:print 0 *default-log-port* "WARNING: db clean up not fully ported to v1.60, cleanup action will be on megatest.db") - (let* ((db (db:dbdat-get-db dbdat)) + (let* ((keep-record-age ( - (current-seconds) (common:hms-string->seconds (or (configf:lookup *configdat* "setup" "delete-record-age") "30d")))) + (db (db:dbdat-get-db dbdat)) (count-stmt (sqlite3:prepare db "SELECT (SELECT count(id) FROM tests)+(SELECT count(id) FROM runs);")) (statements (map (lambda (stmt) (sqlite3:prepare db stmt)) (list ;; delete all tests that belong to runs that are 'deleted' - "DELETE FROM tests WHERE run_id in (SELECT id FROM runs WHERE state='deleted');" + (conc "DELETE FROM tests WHERE run_id in (SELECT id FROM runs WHERE state='deleted') and last_update < " keep-record-age ";") ;; delete all tests that are 'DELETED' - "DELETE FROM tests WHERE state='DELETED';" + (conc "DELETE FROM tests WHERE state='DELETED' and last_update < " keep-record-age " ;") ;; delete all tests that have no run - "DELETE FROM tests WHERE run_id NOT IN (SELECT DISTINCT id FROM runs);" + (conc "DELETE FROM tests WHERE run_id NOT IN (SELECT DISTINCT id FROM runs) and last_update < " keep-record-age "; ") ;; delete all runs that are state='deleted' - "DELETE FROM runs WHERE state='deleted';" + (conc "DELETE FROM runs WHERE state='deleted' and last_update < " keep-record-age ";") ;; delete empty runs - "DELETE FROM runs WHERE id NOT IN (SELECT DISTINCT r.id FROM runs AS r INNER JOIN tests AS t ON t.run_id=r.id);" + (conc "DELETE FROM runs WHERE id NOT IN (SELECT DISTINCT r.id FROM runs AS r INNER JOIN tests AS t ON t.run_id=r.id) and last_update < " keep-record-age ";") + ;; remove orphaned test_rundat entries + (conc "DELETE FROM test_rundat where test_id NOT IN (SELECT id FROM tests);") + ;; remove orphaned test_steps entries + (conc "DELETE FROM test_steps WHERE test_id NOT IN (SELECT id FROM tests);") + ;; remove orphaned test_dat entries + (conc "DELETE FROM test_data WHERE test_id NOT IN (SELECT id FROM tests);") + )))) - (db:delay-if-busy dbdat) + ;; (db:delay-if-busy dbdat) + ;(debug:print-info 0 *default-log-port* statements) (sqlite3:with-transaction db (lambda () (sqlite3:for-each-row (lambda (tot) (debug:print-info 0 *default-log-port* "Records count before clean: " tot)) @@ -1468,11 +2002,11 @@ (debug:print-info 0 *default-log-port* "Records count after clean: " tot)) count-stmt))) (map sqlite3:finalize! statements) (sqlite3:finalize! count-stmt) ;; (db:find-and-mark-incomplete db) - (db:delay-if-busy dbdat) + ;; (db:delay-if-busy dbdat) (sqlite3:execute db "VACUUM;"))) ;; Clean out old junk and vacuum the database ;; ;; Ultimately do something like this: @@ -1495,11 +2029,11 @@ ;; delete all tests that belong to runs that are 'deleted' ;; (conc "DELETE FROM tests WHERE run_id NOT IN (" (string-intersperse (map conc valid-runs) ",") ");") ;; delete all tests that are 'DELETED' "DELETE FROM tests WHERE state='DELETED';" )))) - (db:delay-if-busy dbdat) + ;; (db:delay-if-busy dbdat) (sqlite3:with-transaction db (lambda () (sqlite3:for-each-row (lambda (tot) (debug:print-info 0 *default-log-port* "Records count before clean: " tot)) @@ -1509,11 +2043,11 @@ (debug:print-info 0 *default-log-port* "Records count after clean: " tot)) count-stmt))) (map sqlite3:finalize! statements) (sqlite3:finalize! count-stmt) ;; (db:find-and-mark-incomplete db) - (db:delay-if-busy dbdat) + ;; (db:delay-if-busy dbdat) (sqlite3:execute db "VACUUM;"))) ;; Clean out old junk and vacuum the database ;; ;; Ultimately do something like this: @@ -1542,11 +2076,11 @@ (sqlite3:for-each-row (lambda (run-id) (set! dead-runs (cons run-id dead-runs))) db "SELECT id FROM runs WHERE state='deleted';") - (db:delay-if-busy dbdat) + ;; (db:delay-if-busy dbdat) (sqlite3:with-transaction db (lambda () (sqlite3:for-each-row (lambda (tot) (debug:print-info 0 *default-log-port* "Records count before clean: " tot)) @@ -1556,11 +2090,11 @@ (debug:print-info 0 *default-log-port* "Records count after clean: " tot)) count-stmt))) (map sqlite3:finalize! statements) (sqlite3:finalize! count-stmt) ;; (db:find-and-mark-incomplete db) - (db:delay-if-busy dbdat) + ;; (db:delay-if-busy dbdat) (sqlite3:execute db "VACUUM;") dead-runs)) ;;====================================================================== ;; M E T A G E T A N D S E T V A R S @@ -1568,23 +2102,34 @@ ;; returns number if string->number is successful, string otherwise ;; also updates *global-delta* ;; (define (db:get-var dbstruct var) - (let* ((res #f) - (dbdat (db:get-db dbstruct #f)) - (db (db:dbdat-get-db dbdat))) - (sqlite3:for-each-row - (lambda (val) - (set! res val)) - db - "SELECT val FROM metadat WHERE var=?;" var) - ;; convert to number if can - (if (string? res) - (let ((valnum (string->number res))) - (if valnum (set! res valnum)))) - res)) + (let* ((res #f)) + (db:with-db + dbstruct #f #f + (lambda (db) + (sqlite3:for-each-row + (lambda (val) + (set! res val)) + db + "SELECT val FROM metadat WHERE var=?;" var) + ;; convert to number if can + (if (string? res) + (let ((valnum (string->number res))) + (if valnum (set! res valnum)))) + res)))) + +(define (db:inc-var dbstruct var) + (db:with-db dbstruct #f #t + (lambda (db) + (sqlite3:execute db "UPDATE metadat SET val=val+1 WHERE var=?;" var)))) + +(define (db:dec-var dbstruct var) + (db:with-db dbstruct #f #t + (lambda (db) + (sqlite3:execute db "UPDATE metadat SET val=val-1 WHERE var=?;" var)))) ;; This was part of db:get-var. It was used to estimate the load on ;; the database files. ;; ;; scale by 10, average with current value. @@ -1595,19 +2140,154 @@ ;; (begin ;; (debug:print-info 4 *default-log-port* "launch throttle factor=" *global-delta*) ;; (set! *last-global-delta-printed* *global-delta*))) (define (db:set-var dbstruct var val) - (let* ((dbdat (db:get-db dbstruct #f)) - (db (db:dbdat-get-db dbdat))) - (sqlite3:execute db "INSERT OR REPLACE INTO metadat (var,val) VALUES (?,?);" var val))) + (db:with-db dbstruct #f #t + (lambda (db) + (sqlite3:execute db "INSERT OR REPLACE INTO metadat (var,val) VALUES (?,?);" var val)))) + +(define (db:add-var dbstruct var val) + (db:with-db dbstruct #f #t + (lambda (db) + (sqlite3:execute db "UPDATE metadat SET val=val+? WHERE var=?;" val var)))) (define (db:del-var dbstruct var) - ;; (db:delay-if-busy) (db:with-db dbstruct #f #t (lambda (db) (sqlite3:execute db "DELETE FROM metadat WHERE var=?;" var)))) + +;;====================================================================== +;; no-sync.db - small bits of data to be shared between servers +;;====================================================================== + +(define (db:open-no-sync-db) + (let* ((dbpath (db:dbfile-path)) + (dbname (conc dbpath "/no-sync.db")) + (db-exists (common:file-exists? dbname)) + (db (sqlite3:open-database dbname))) + (sqlite3:set-busy-handler! db (sqlite3:make-busy-timeout 136000)) + (if (not db-exists) + (begin + (sqlite3:execute db "CREATE TABLE IF NOT EXISTS no_sync_metadat (var TEXT,val TEXT, CONSTRAINT no_sync_metadat_constraint UNIQUE (var));") + (sqlite3:execute db "PRAGMA journal_mode=WAL;"))) + ;; MOVE THIS TABLE CREATION TO THE (begin above in about six months (it is Sep 2020 right now). + (sqlite3:execute db "CREATE TABLE IF NOT EXISTS jobs_queue (id INTEGER PRIMARY KEY, host_type TEXT, cores INTEGER, memory TEXT, vars TEXT, exekey TEXT, cmdline TEXT, state TEXT, event_time INTEGER, last_update INTEGER);") + ;; not sure I'll use this next one. I prefer if tests simply append to a file: + ;; last-update-seconds cpuload tmpspace rundirspace + (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_extra_data (id INTEGER PRIMARY KEY, run_id INTEGER, test_id INTEGER, last_seen_running INTEGER);") + (sqlite3:execute db "PRAGMA synchronous = 0;") + db)) + +(define (db:no-sync-add-job db-in host-type vars-list exekey cmdline) + (sqlite3:execute (db:no-sync-db db-in) "INSERT INTO jobs_queue (host_type,vars,exekey,cmdline,state,event_time,last_update) VALUES (?,?,?,?,?,?,?);" + host-type + (with-output-to-string + (lambda () + (write vars-list))) + exekey cmdline "waiting" (current-seconds)(current-seconds))) + +;; find next job (waiting longest) that matches host-type - future, we'll find jobs that fit if no exact match +(define (db:no-sync-take-job db-in host-type) + (let* ((db (db:no-sync-db db-in)) + (stmt1 "SELECT id,host_type,vars,exekey,cmdline,state,event_time,last_update FROM jobs_queue WHERE host_type=? AND state != 'taken' ORDER BY event_time ASC;") + (stmt1h (sqlite3:prepare db stmt1)) + (stmt2 "UPDATE jobs_queue SET state='taken',last_update=? WHERE id=?;") + (stmt2h (sqlite3:prepare db stmt2)) + (res (sqlite3:with-transaction + db + (lambda () + (let* ((matching-jobs (sqlite3:fold-row + (lambda (res . row) ;; id host-type vars exekey state event-time last-update) + (cons row res)) + '() + stmt1h + host-type))) + (if (null? matching-jobs) + #f + (let ((choosen-one (let loop ((tal matching-jobs) + (res #f)) ;; put bestest one in here + (if (null? tal) + res + (let ((curr (car tal)) + (rem (cdr tal))) + curr) ;; here we will compare with res, if better candidate the loop with curr else loop with res + )))) + (if choosen-one ;; we need to mark it as taken + (sqlite3:execute stmt2h (current-seconds) (car choosen-one))) + choosen-one))))))) + (sqlite3:finalize! stmt1h) ;; it'd be nice to cache these and finalize on exit. + (sqlite3:finalize! stmt2h) + res)) + +;; clean out old jobs in queue, i.e. taken and event_time > 24 hrs ago +;; +(define (db:no-sync-job-records-clean db) + (sqlite3:execute (db:no-sync-db db) "DELETE FROM jobs_queue WHERE state='taken' AND event_time < ?;" (- (current-seconds)(* 24 3600)))) + + +;; if we are not a server create a db handle. this is not finalized +;; so watch for problems. I'm still not clear if it is needed to manually +;; finalize sqlite3 dbs with the sqlite3 egg. +;; +(define (db:no-sync-db db-in) + (mutex-lock! *db-access-mutex*) + (let ((res (if db-in + db-in + (let ((db (db:open-no-sync-db))) + (set! *no-sync-db* db) + db)))) + (mutex-unlock! *db-access-mutex*) + res)) + +(define (db:no-sync-set db var val) + (sqlite3:execute (db:no-sync-db db) "INSERT OR REPLACE INTO no_sync_metadat (var,val) VALUES (?,?);" var val)) + +(define (db:no-sync-del! db var) + (sqlite3:execute (db:no-sync-db db) "DELETE FROM no_sync_metadat WHERE var=?;" var)) + +(define (db:no-sync-get/default db-in var default) + (let ((db (db:no-sync-db db-in)) + (res default)) + (sqlite3:for-each-row + (lambda (val) + (set! res val)) + (db:no-sync-db db) + "SELECT val FROM no_sync_metadat WHERE var=?;" + var) + (if res + (let ((newres (if (string? res) + (string->number res) + #f))) + (if newres + newres + res)) + res))) + +(define (db:no-sync-close-db db stmt-cache) + (db:safely-close-sqlite3-db db stmt-cache)) + +;; transaction protected lock aquisition +;; either: +;; fails returns (#f . lock-creation-time) +;; succeeds (returns (#t . lock-creation-time) +;; use (db:no-sync-del! db keyname) to release the lock +;; +(define (db:no-sync-get-lock db-in keyname) + (let ((db (db:no-sync-db db-in))) + (sqlite3:with-transaction + db + (lambda () + (handle-exceptions + exn + (let ((lock-time (current-seconds))) + (debug:print-info 2 *default-log-port* "db:no-sync-get-lock keyname=" keyname ", lock-time=" lock-time ", exn=" exn) + (sqlite3:execute db "INSERT INTO no_sync_metadat (var,val) VALUES(?,?);" keyname lock-time) + `(#t . ,lock-time)) + `(#f . ,(sqlite3:first-result db "SELECT val FROM no_sync_metadat WHERE var=?;" keyname))))))) + + ;; use a global for some primitive caching, it is just silly to ;; re-read the db over and over again for the keys since they never ;; change @@ -1625,19 +2305,29 @@ db "SELECT fieldname FROM keys ORDER BY id DESC;"))) (set! *db-keys* res) res))) +;; extract index number given a header/data structure +(define (db:get-index-by-header header field) + (list-index (lambda (x)(equal? x field)) header)) + ;; look up values in a header/data structure (define (db:get-value-by-header row header field) (if (or (null? header) (not row)) #f (let loop ((hed (car header)) - (tal (cdr header)) - (n 0)) - (if (equal? hed field) - (vector-ref row n) + (tal (cdr header)) + (n 0)) + (if (equal? hed field) + (handle-exceptions + exn + (begin + (debug:print 0 *default-log-port* "WARNING: attempt to read non-existant field, row=" + row " header=" header " field=" field ", exn=" exn) + #f) + (vector-ref row n)) (if (null? tal) #f (loop (car tal)(cdr tal)(+ n 1))))))) ;; Accessors for the header/data structure ;; get rows and header from (define (db:get-header vec)(vector-ref vec 0)) @@ -1644,10 +2334,34 @@ (define (db:get-rows vec)(vector-ref vec 1)) ;;====================================================================== ;; R U N S ;;====================================================================== + + + + + +(define (db:get-run-times dbstruct run-patt target-patt) +(let ((res `()) + (qry (conc "select runname, (max(end_time)-min(event_time))/60 as runtime, target from (select runname, run_id,tests.event_time,tests.event_time+run_duration AS end_time, " (string-join (db:get-keys dbstruct) " || '/' || ") " as target from tests inner join runs on tests.run_id = runs.id where runs.runname like ? and target like ?) group by run_id ;"))) +;(print qry) +(db:with-db + dbstruct + #f ;; this is for the main runs db + #f ;; does not modify db + (lambda (db) + (sqlite3:for-each-row + (lambda (runname runtime target ) + (set! res (cons (vector runname runtime target) res))) + db + qry + run-patt target-patt) + + res)))) + + (define (db:get-run-name-from-id dbstruct run-id) (db:with-db dbstruct #f ;; this is for the main runs db @@ -1699,40 +2413,38 @@ ;; register a test run with the db, this accesses the main.db and does NOT ;; use server api ;; -(define (db:register-run dbstruct keyvals runname state status user) - (let* ((dbdat (db:get-db dbstruct #f)) - (db (db:dbdat-get-db dbdat)) - (keys (map car keyvals)) - (keystr (keys->keystr keys)) +(define (db:register-run dbstruct keyvals runname state status user contour-in) + (let* ((keys (map car keyvals)) + (keystr (keys->keystr keys)) + (contour (or contour-in "")) ;; empty string to force no hierarcy and be backwards compatible. (comma (if (> (length keys) 0) "," "")) (andstr (if (> (length keys) 0) " AND " "")) (valslots (keys->valslots keys)) ;; ?,?,? ... - (allvals (append (list runname state status user) (map cadr keyvals))) + (allvals (append (list runname state status user contour) (map cadr keyvals))) (qryvals (append (list runname) (map cadr keyvals))) (key=?str (string-intersperse (map (lambda (k)(conc k "=?")) keys) " AND "))) (debug:print 3 *default-log-port* "keys: " keys " allvals: " allvals " keyvals: " keyvals " key=?str is " key=?str) (debug:print 2 *default-log-port* "NOTE: using target " (string-intersperse (map cadr keyvals) "/") " for this run") (if (and runname (null? (filter (lambda (x)(not x)) keyvals))) ;; there must be a better way to "apply and" - (let ((res #f)) - (db:delay-if-busy dbdat) - (apply sqlite3:execute db (conc "INSERT OR IGNORE INTO runs (runname,state,status,owner,event_time" comma keystr ") VALUES (?,?,?,?,strftime('%s','now')" comma valslots ");") - allvals) - (db:delay-if-busy dbdat) - (apply sqlite3:for-each-row - (lambda (id) - (set! res id)) - db - (let ((qry (conc "SELECT id FROM runs WHERE (runname=? " andstr key=?str ");"))) - ;(debug:print 4 *default-log-port* "qry: " qry) - qry) - qryvals) - (db:delay-if-busy dbdat) - (sqlite3:execute db "UPDATE runs SET state=?,status=?,event_time=strftime('%s','now') WHERE id=? AND state='deleted';" state status res) - res) + (db:with-db + dbstruct #f #f + (lambda (db) + (let ((res #f)) + (apply sqlite3:execute db (conc "INSERT OR IGNORE INTO runs (runname,state,status,owner,event_time,contour" comma keystr ") VALUES (?,?,?,?,strftime('%s','now'),?" comma valslots ");") + allvals) + (apply sqlite3:for-each-row + (lambda (id) + (set! res id)) + db + (let ((qry (conc "SELECT id FROM runs WHERE (runname=? " andstr key=?str ");"))) + qry) + qryvals) + (sqlite3:execute db "UPDATE runs SET state=?,status=?,event_time=strftime('%s','now') WHERE id=? AND state='deleted';" state status res) + res))) (begin (debug:print-error 0 *default-log-port* "Called without all necessary keys") #f)))) ;; replace header and keystr with a call to runs:get-std-run-fields @@ -1776,14 +2488,57 @@ qrystr ))) (debug:print-info 11 *default-log-port* "db:get-runs END qrystr: " qrystr " keypatts: " keypatts " offset: " offset " limit: " count) (vector header res))) + +(define-record simple-run target id runname state status owner event_time) +(define-record-printer (simple-run x out) + (fprintf out "#,(simple-run ~S ~S ~S ~S)" + (simple-run-target x) (simple-run-id x) (simple-run-runname x) (time->string (seconds->local-time (simple-run-event_time x) )))) + +;; simple get-runs +;; +(define (db:simple-get-runs dbstruct runpatt count offset target last-update) + (let* ((res '()) + (keys (db:get-keys dbstruct)) + (runpattstr (db:patt->like "runname" runpatt)) + (remfields (list "id" "runname" "state" "status" "owner" "event_time")) + (targstr (string-intersperse keys "||'/'||")) + (keystr (conc targstr " AS target," + (string-intersperse remfields ","))) + (qrystr (conc "SELECT " keystr " FROM runs WHERE (" runpattstr ") " ;; runname LIKE ? " + ;; Generate: " AND x LIKE 'keypatt' ..." + " AND target LIKE '" target "'" + " AND state != 'deleted' " + (if (number? last-update) + (conc " AND last_update >= " last-update) + "") + " ORDER BY event_time DESC " + (if (number? count) + (conc " LIMIT " count) + "") + (if (number? offset) + (conc " OFFSET " offset) + ""))) + ) + (debug:print-info 11 *default-log-port* "db:get-runs START qrystr: " qrystr " target: " target " offset: " offset " limit: " count) + (db:with-db dbstruct #f #f + (lambda (db) + (sqlite3:for-each-row + (lambda (target id runname state status owner event_time) + (set! res (cons (make-simple-run target id runname state status owner event_time) res))) + db + qrystr + ))) + (debug:print-info 11 *default-log-port* "db:get-runs END qrystr: " qrystr " target: " target " offset: " offset " limit: " count) + res)) + ;; TODO: Switch this to use max(update_time) from each run db? Then if using a server there is no disk traffic (using inmem db) ;; (define (db:get-changed-run-ids since-time) - (let* ((dbdir (db:dbfile-path #f)) ;; (configf:lookup *configdat* "setup" "dbdir")) + (let* ((dbdir (db:dbfile-path)) ;; (configf:lookup *configdat* "setup" "dbdir")) (alldbs (glob (conc dbdir "/[0-9]*.db"))) (changed (filter (lambda (dbfile) (> (file-modification-time dbfile) since-time)) alldbs))) (delete-duplicates @@ -1836,10 +2591,47 @@ (set! numruns count)) db "SELECT COUNT(id) FROM runs WHERE runname LIKE ? AND state != 'deleted';" runpatt) (debug:print-info 11 *default-log-port* "db:get-num-runs END " runpatt) numruns)))) + +;; just get count of runs +(define (db:get-runs-cnt-by-patt dbstruct runpatt targetpatt keys) + (db:with-db + dbstruct + #f + #f + (lambda (db) + (let ((numruns 0) + (qry-str #f) + (key-patt "") + (keyvals (if targetpatt (keys:target->keyval keys targetpatt) '()))) + + (for-each (lambda (keyval) + (let* ((key (car keyval)) + (patt (cadr keyval)) + (fulkey (conc ":" key)) + (wildtype (if (substring-index "%" patt) "like" "glob"))) + + (if patt + (set! key-patt (conc key-patt " AND " key " " wildtype " '" patt "'")) + (begin + (debug:print-error 0 *default-log-port* "searching for runs with no pattern set for " fulkey) + (exit 6))))) + keyvals) + ;(print runpatt " -- " key-patt) + (set! qry-str (conc "SELECT COUNT(id) FROM runs WHERE state != 'deleted' AND runname like '" runpatt "'" key-patt)) + ;(print qry-str ) + + (sqlite3:for-each-row + (lambda (count) + (set! numruns count)) + db + qry-str) + (debug:print-info 11 *default-log-port* "db:get-num-runs END " runpatt) + numruns)))) + ;; (sqlite3#fold-row proc3670 init3671 db-or-stmt3672 . params3673)> ;; (define (db:get-raw-run-stats dbstruct run-id) (db:with-db @@ -1850,23 +2642,26 @@ (sqlite3:fold-row (lambda (res state status count) (cons (list state status count) res)) '() db - "SELECT state,status,count(id) AS count FROM tests WHERE run_id=? AND NOT(uname='n/a' AND item_path='') GROUP BY state,status;;" + "SELECT state,status,count(id) AS count FROM tests WHERE run_id=? AND NOT(uname='n/a' AND item_path='') GROUP BY state,status;" run-id)))) ;; Update run_stats for given run_id ;; input data is a list (state status count) ;; (define (db:update-run-stats dbstruct run-id stats) + ;; (mutex-lock! *db-transaction-mutex*) (db:with-db dbstruct #f #f + (lambda (db) ;; remove previous data + (let* ((stmt1 (sqlite3:prepare db "DELETE FROM run_stats WHERE run_id=? AND state=? AND status=?;")) (stmt2 (sqlite3:prepare db "INSERT INTO run_stats (run_id,state,status,count) VALUES (?,?,?,?);")) (res (sqlite3:with-transaction db @@ -1876,10 +2671,11 @@ (sqlite3:execute stmt1 run-id (car dat)(cadr dat)) (apply sqlite3:execute stmt2 run-id dat)) stats))))) (sqlite3:finalize! stmt1) (sqlite3:finalize! stmt2) + ;; (mutex-unlock! *db-transaction-mutex*) res)))) (define (db:get-main-run-stats dbstruct run-id) (db:with-db dbstruct @@ -1892,10 +2688,29 @@ '() db "SELECT state,status,count FROM run_stats WHERE run_id=? AND run_id IN (SELECT id FROM runs WHERE state NOT IN ('DELETED','deleted'));" run-id)))) +(define (db:print-current-query-stats) + ;; generate stats from *db-api-call-time* + (let ((ordered-keys (sort (hash-table-keys *db-api-call-time*) + (lambda (a b) + (let ((sum-a (common:sum (hash-table-ref *db-api-call-time* a))) + (sum-b (common:sum (hash-table-ref *db-api-call-time* b)))) + (> sum-a sum-b))))) + (total 0)) + (for-each + (lambda (cmd-key) + (let* ((dat (hash-table-ref *db-api-call-time* cmd-key)) + (num (length dat)) + (avg (if (> num 0) + (/ (common:sum dat)(length dat))))) + (set! total (+ total num)) + (debug:print-info 0 *default-log-port* cmd-key "\tavg: " avg " max: " (common:max dat) " min: " (common:min-max < dat) " num: " (length dat)))) + ordered-keys) + (debug:print-info 0 *default-log-port* "TOTAL: " total " api calls since start."))) + (define (db:get-all-run-ids dbstruct) (db:with-db dbstruct #f #f @@ -1907,27 +2722,30 @@ db "SELECT id FROM runs WHERE state != 'deleted' ORDER BY event_time DESC;") (reverse run-ids))))) ;; get some basic run stats +;; +;; data structure: ;; ;; ( (runname (( state count ) ... )) -;; ( ... +;; ( ... +;; (define (db:get-run-stats dbstruct) - (let* ((dbdat (db:get-db dbstruct #f)) - (db (db:dbdat-get-db dbdat)) - (totals (make-hash-table)) + (let* ((totals (make-hash-table)) (curr (make-hash-table)) (res '()) (runs-info '())) ;; First get all the runname/run-ids - (db:delay-if-busy dbdat) - (sqlite3:for-each-row - (lambda (run-id runname) - (set! runs-info (cons (list run-id runname) runs-info))) - db - "SELECT id,runname FROM runs WHERE state != 'deleted' ORDER BY event_time DESC;") ;; If you change this to the more logical ASC please adjust calls to db:get-run-stats + (db:with-db + dbstruct #f #f + (lambda (db) + (sqlite3:for-each-row + (lambda (run-id runname) + (set! runs-info (cons (list run-id runname) runs-info))) + db + "SELECT id,runname FROM runs WHERE state != 'deleted' ORDER BY event_time DESC;"))) ;; If you change this to the more logical ASC please adjust calls to db:get-run-stats ;; for each run get stats data (for-each (lambda (run-info) ;; get the net state/status counts for this run (let* ((run-id (car run-info)) @@ -1943,11 +2761,12 @@ (if (string? netstate) (begin (hash-table-set! totals netstate (+ (hash-table-ref/default totals netstate 0) count)) (hash-table-set! curr netstate (+ (hash-table-ref/default curr netstate 0) count)))))) db - "SELECT state,status,count(id) FROM tests AS t GROUP BY state,status ORDER BY state,status DESC;") + "SELECT state,status,count(id) FROM tests AS t WHERE run_id=? GROUP BY state,status ORDER BY state,status DESC;" + run-id) ;; add the per run counts to res (for-each (lambda (state) (set! res (cons (list run-name state (hash-table-ref curr state)) res))) (sort (hash-table-keys curr) string>=)) (set! curr (make-hash-table)))))) @@ -1962,15 +2781,14 @@ ;; register a test run with the db ;; ;; Use: (db:get-value-by-header (db:get-header runinfo)(db:get-rows runinfo)) ;; to extract info from the structure returned ;; -(define (db:get-runs-by-patt dbstruct keys runnamepatt targpatt offset limit fields last-update) ;; test-name) +(define (db:get-runs-by-patt dbstruct keys runnamepatt targpatt offset limit fields last-update sort-order ) ;; test-name) (let* ((tmp (runs:get-std-run-fields keys (or fields '("id" "runname" "state" "status" "owner" "event_time")))) (keystr (car tmp)) (header (cadr tmp)) - (res '()) (key-patt "") (runwildtype (if (substring-index "%" runnamepatt) "like" "glob")) (qry-str #f) (keyvals (if targpatt (keys:target->keyval keys targpatt) '()))) (for-each (lambda (keyval) @@ -1986,86 +2804,88 @@ keyvals) (set! qry-str (conc "SELECT " keystr " FROM runs WHERE state != 'deleted' AND runname " runwildtype " ? " key-patt (if last-update (conc " AND last_update >= " last-update " ") " ") - " ORDER BY event_time " + " ORDER BY event_time " sort-order " " (if limit (conc " LIMIT " limit) "") (if offset (conc " OFFSET " offset) "") ";")) (debug:print-info 4 *default-log-port* "runs:get-runs-by-patt qry=" qry-str " " runnamepatt) - (db:with-db dbstruct #f #f ;; reads db, does not write to it. - (lambda (db) - (sqlite3:for-each-row - (lambda (a . r) - (set! res (cons (list->vector (cons a r)) res))) - db - qry-str - runnamepatt))) - (vector header res))) + ;(print "runs:get-runs-by-patt qry=" qry-str " " runnamepatt) + + (vector header + (reverse + (db:with-db dbstruct #f #f ;; reads db, does not write to it. + (lambda (db) + (sqlite3:fold-row + (lambda (res . r) + (cons (list->vector r) res)) + '() + db + qry-str + runnamepatt))))))) ;; use (get-value-by-header (db:get-header runinfo)(db:get-rows runinfo)) +;; NOTE: Does NOT return a list of rows (or one row) for the first slot of the vector +;; this is inconsistent with get-runs but it makes some sense. +;; (define (db:get-run-info dbstruct run-id) ;;(if (hash-table-ref/default *run-info-cache* run-id #f) ;; (hash-table-ref *run-info-cache* run-id) - (let* ((dbdat (db:get-db dbstruct #f)) - (db (db:dbdat-get-db dbdat)) - (res (vector #f #f #f #f)) + (let* ((res (vector #f #f #f #f)) (keys (db:get-keys dbstruct)) - (remfields (list "id" "runname" "state" "status" "owner" "event_time")) + (remfields (list "id" "runname" "state" "status" "owner" "event_time" "comment" "fail_count" "pass_count" "contour" "last_update")) ;; "area_id")) (header (append keys remfields)) (keystr (conc (keys->keystr keys) "," (string-intersperse remfields ",")))) (debug:print-info 11 *default-log-port* "db:get-run-info run-id: " run-id " header: " header " keystr: " keystr) - (db:delay-if-busy dbdat) - (sqlite3:for-each-row - (lambda (a . x) - (set! res (apply vector a x))) - db - (conc "SELECT " keystr " FROM runs WHERE id=? AND state != 'deleted';") - run-id) + + (db:with-db + dbstruct #f #f + (lambda (db) + (sqlite3:for-each-row + (lambda (a . x) + (set! res (apply vector a x))) + db + (conc "SELECT " keystr " FROM runs WHERE id=?;") + run-id))) (debug:print-info 11 *default-log-port* "db:get-run-info run-id: " run-id " header: " header " keystr: " keystr) (let ((finalres (vector header res))) ;; (hash-table-set! *run-info-cache* run-id finalres) finalres))) (define (db:set-comment-for-run dbstruct run-id comment) (db:with-db - dbstruct - #f - #f + dbstruct #f #f (lambda (db) (sqlite3:execute db "UPDATE runs SET comment=? WHERE id=?;" comment ;; (sdb:qry 'getid comment) run-id)))) ;; does not (obviously!) removed dependent data. But why not!!? (define (db:delete-run dbstruct run-id) - ;; First set any related tests to DELETED - (let* ((rdbdat (db:get-db dbstruct run-id)) - (rdb (db:dbdat-get-db rdbdat)) - (dbdat (db:get-db dbstruct #f)) - (db (db:dbdat-get-db dbdat))) - (db:delay-if-busy rdbdat) - (sqlite3:execute rdb "UPDATE tests SET state='DELETED',comment='';") - (sqlite3:execute rdb "DELETE FROM test_steps;") - (sqlite3:execute rdb "DELETE FROM test_data;") - (db:delay-if-busy dbdat) - (sqlite3:execute db "UPDATE runs SET state='deleted',comment='' WHERE id=?;" run-id))) + (db:with-db + dbstruct #f #f + (lambda (db) + (sqlite3:with-transaction + db + (lambda () + (sqlite3:execute db "DELETE FROM test_steps WHERE test_id IN (SELECT id FROM tests WHERE run_id=?);" run-id) + (sqlite3:execute db "DELETE FROM test_data WHERE test_id IN (SELECT id FROM tests WHERE run_id=?);" run-id) + (sqlite3:execute db "UPDATE tests SET state='DELETED',comment='' WHERE run_id=?;" run-id) + ;; (db:delay-if-busy dbdat) + (sqlite3:execute db "UPDATE runs SET state='deleted',comment='' WHERE id=?;" run-id)))))) (define (db:update-run-event_time dbstruct run-id) (db:with-db - dbstruct - #f - #t + dbstruct #f #t (lambda (db) (sqlite3:execute db "UPDATE runs SET event_time=strftime('%s','now') WHERE id=?;" run-id)))) (define (db:lock/unlock-run dbstruct run-id lock unlock user) (db:with-db - dbstruct - #f - #t + dbstruct #f #t (lambda (db) (let ((newlockval (if lock "locked" (if unlock "unlocked" "locked")))) ;; semi-failsafe @@ -2073,69 +2893,90 @@ (sqlite3:execute db "INSERT INTO access_log (user,accessed,args) VALUES(?,strftime('%s','now'),?);" user (conc newlockval " " run-id)) (debug:print-info 1 *default-log-port* "" newlockval " run number " run-id))))) (define (db:set-run-status dbstruct run-id status msg) - (let* ((dbdat (db:get-db dbstruct #f)) - (db (db:dbdat-get-db dbdat))) - (db:delay-if-busy dbdat) - (if msg - (sqlite3:execute db "UPDATE runs SET status=?,comment=? WHERE id=?;" status msg run-id) - (sqlite3:execute db "UPDATE runs SET status=? WHERE id=?;" status run-id)))) + (db:with-db + dbstruct #f #f + (lambda (db) + (if msg + (sqlite3:execute db "UPDATE runs SET status=?,comment=? WHERE id=?;" status msg run-id) + (sqlite3:execute db "UPDATE runs SET status=? WHERE id=?;" status run-id))))) + +(define (db:set-run-state-status dbstruct run-id state status ) + (db:with-db + dbstruct #f #f + (lambda (db) + (sqlite3:execute db "UPDATE runs SET status=?,state=? WHERE id=?;" status state run-id)))) + + (define (db:get-run-status dbstruct run-id) (let ((res "n/a")) (db:with-db - dbstruct - #f - #f + dbstruct #f #f (lambda (db) (sqlite3:for-each-row (lambda (status) (set! res status)) db "SELECT status FROM runs WHERE id=?;" run-id) res)))) + +(define (db:get-run-state dbstruct run-id) + (let ((res "n/a")) + (db:with-db + dbstruct #f #f + (lambda (db) + (sqlite3:for-each-row + (lambda (status) + (set! res status)) + db + "SELECT state FROM runs WHERE id=?;" + run-id) + res)))) + ;;====================================================================== ;; K E Y S ;;====================================================================== ;; get key val pairs for a given run-id ;; ( (FIELDNAME1 keyval1) (FIELDNAME2 keyval2) ... ) (define (db:get-key-val-pairs dbstruct run-id) (let* ((keys (db:get-keys dbstruct)) - (res '()) - (dbdat (db:get-db dbstruct #f)) - (db (db:dbdat-get-db dbdat))) - (for-each - (lambda (key) - (let ((qry (conc "SELECT " key " FROM runs WHERE id=?;"))) - (db:delay-if-busy dbdat) - (sqlite3:for-each-row - (lambda (key-val) - (set! res (cons (list key key-val) res))) - db qry run-id))) - keys) - (reverse res))) + (res '())) + (db:with-db + dbstruct #f #f + (lambda (db) + (for-each + (lambda (key) + (let ((qry (conc "SELECT " key " FROM runs WHERE id=?;"))) + (sqlite3:for-each-row + (lambda (key-val) + (set! res (cons (list key (if (string? key-val) key-val "")) res))) ;; replace non-string bad values with empty string to prevent crashes. This scenario can happen when Megatest is killed on updating the db + db qry run-id))) + keys))) + (reverse res))) ;; get key vals for a given run-id (define (db:get-key-vals dbstruct run-id) (let* ((keys (db:get-keys dbstruct)) - (res '()) - (dbdat (db:get-db dbstruct #f)) - (db (db:dbdat-get-db dbdat))) - (for-each - (lambda (key) - (let ((qry (conc "SELECT " key " FROM runs WHERE id=?;"))) - (db:delay-if-busy dbdat) - (sqlite3:for-each-row - (lambda (key-val) - (set! res (cons key-val res))) - db qry run-id))) - keys) + (res '())) + (db:with-db + dbstruct #f #f + (lambda (db) + (for-each + (lambda (key) + (let ((qry (conc "SELECT " key " FROM runs WHERE id=?;"))) + ;; (db:delay-if-busy dbdat) + (sqlite3:for-each-row + (lambda (key-val) + (set! res (cons (if (string? key-val) key-val "") res))) ;; check that the key-val is a string for cases where a crash injected bad data in the megatest.db + db qry run-id))) + keys))) (let ((final-res (reverse res))) (hash-table-set! *keyvals* run-id final-res) final-res))) ;; The target is keyval1/keyval2..., cached in *target* as it is used often @@ -2145,23 +2986,27 @@ thekey)) ;; Get run-ids for runs with same target but different runnames and NOT run-id ;; (define (db:get-prev-run-ids dbstruct run-id) - (let* ((keyvals (rmt:get-key-val-pairs run-id)) + (let* ((keyvals (db:get-key-val-pairs dbstruct run-id)) (kvalues (map cadr keyvals)) (keys (rmt:get-keys)) (qrystr (string-intersperse (map (lambda (x)(conc x "=?")) keys) " AND "))) (let ((prev-run-ids '())) - (db:with-db dbstruct #f #f ;; #f means work with the zeroth db - i.e. the runs db - (lambda (db) - (apply sqlite3:for-each-row - (lambda (id) - (set! prev-run-ids (cons id prev-run-ids))) - db - (conc "SELECT id FROM runs WHERE " qrystr " AND state != 'deleted' AND id != ?;") (append kvalues (list run-id))))) - prev-run-ids))) + (if (null? keyvals) + '() + (begin + (db:with-db dbstruct #f #f ;; #f means work with the zeroth db - i.e. the runs db + (lambda (db) + (apply sqlite3:for-each-row + (lambda (id) + (set! prev-run-ids (cons id prev-run-ids))) + db + (conc "SELECT id FROM runs WHERE " qrystr " AND state != 'deleted' AND id != ?;") + (append kvalues (list run-id))))) + prev-run-ids))))) ;;====================================================================== ;; T E S T S ;;====================================================================== @@ -2171,99 +3016,100 @@ ;; not-in #t = above behaviour, #f = must match ;; mode: ;; 'dashboard - use state = 'COMPLETED' AND status in ( statuses ) OR state in ( states ) ;; (define (db:get-tests-for-run dbstruct run-id testpatt states statuses offset limit not-in sort-by sort-order qryvals last-update mode) - (if (not (number? run-id)) - (begin ;; no need to treat this as an error by default - (debug:print 4 *default-log-port* "WARNING: call to db:get-tests-for-run with bad run-id=" run-id) - ;; (print-call-chain (current-error-port)) - '()) - (let* ((qryvalstr (case qryvals - ((shortlist) "id,run_id,testname,item_path,state,status") - ((#f) db:test-record-qry-selector) ;; "id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment") - (else qryvals))) - (res '()) - ;; if states or statuses are null then assume match all when not-in is false - (states-qry (if (null? states) - #f - (conc " state " - (if (eq? mode 'dashboard) - " IN ('" - (if not-in - " NOT IN ('" - " IN ('")) - (string-intersperse states "','") - "')"))) - (statuses-qry (if (null? statuses) - #f - (conc " status " - (if (eq? mode 'dashboard) - " IN ('" - (if not-in - " NOT IN ('" - " IN ('") ) - (string-intersperse statuses "','") - "')"))) - (interim-qry (conc " AND " (if not-in "NOT " "") "( state='COMPLETED' " (if statuses-qry (conc " AND " statuses-qry " ) ") " ) ") - (if states-qry - (conc (if not-in " AND " " OR ") states-qry ) ;; " ) ") - ""))) - (states-statuses-qry - (cond - ((and states-qry statuses-qry) - (case mode - ((dashboard) - (if not-in - (conc " AND (state='COMPLETED' AND status NOT IN ('" (string-intersperse statuses "','") "')) " - " OR (state != 'COMPLETED' AND state NOT IN ('" (string-intersperse states "','") "')) ") - (conc " AND (state='COMPLETED' AND status IN ('" (string-intersperse statuses "','") "')) " - " OR (state NOT IN ('COMPLETED','DELETED') AND state IN ('" (string-intersperse states "','") "')) "))) - (else (conc " AND ( " states-qry " AND " statuses-qry " ) ")))) - (states-qry - (case mode - ((dashboard) (conc " AND " (if not-in "NOT " "") " state IN ('" (string-intersperse states "','") "') ")) ;; interim-qry) - (else (conc " AND " states-qry)))) - (statuses-qry - (case mode - ((dashboard) (conc " AND " (if not-in "NOT " "") " status IN ('" (string-intersperse statuses "','") "') ")) ;; interim-qry) - (else (conc " AND " statuses-qry)))) - (else ""))) - (tests-match-qry (tests:match->sqlqry testpatt)) - (qry (conc "SELECT " qryvalstr + (let* ((qryvalstr (case qryvals + ((shortlist) "id,run_id,testname,item_path,state,status") + ((#f) db:test-record-qry-selector) ;; "id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment") + (else qryvals))) + (res '()) + ;; if states or statuses are null then assume match all when not-in is false + (states-qry (if (null? states) + #f + (conc " state " + (if (eq? mode 'dashboard) + " IN ('" + (if not-in + " NOT IN ('" + " IN ('")) + (string-intersperse states "','") + "')"))) + (statuses-qry (if (null? statuses) + #f + (conc " status " + (if (eq? mode 'dashboard) + " IN ('" + (if not-in + " NOT IN ('" + " IN ('") ) + (string-intersperse statuses "','") + "')"))) + (interim-qry (conc " AND " (if not-in "NOT " "") "( state='COMPLETED' " (if statuses-qry (conc " AND " statuses-qry " ) ") " ) ") + (if states-qry + (conc (if not-in " AND " " OR ") states-qry ) ;; " ) ") + ""))) + (states-statuses-qry + (cond + ((and states-qry statuses-qry) + (case mode + ((dashboard) + (if not-in + (conc " AND (state='COMPLETED' AND status NOT IN ('" (string-intersperse statuses "','") "')) " + " OR (state != 'COMPLETED' AND state NOT IN ('" (string-intersperse states "','") "')) ") + (conc " AND (state='COMPLETED' AND status IN ('" (string-intersperse statuses "','") "')) " + " OR (state NOT IN ('COMPLETED','DELETED') AND state IN ('" (string-intersperse states "','") "')) "))) + (else (conc " AND ( " states-qry " AND " statuses-qry " ) ")))) + (states-qry + (case mode + ((dashboard) (conc " AND " (if not-in "NOT " "") " state IN ('" (string-intersperse states "','") "') ")) ;; interim-qry) + (else (conc " AND " states-qry)))) + (statuses-qry + (case mode + ((dashboard) (conc " AND " (if not-in "NOT " "") " status IN ('" (string-intersperse statuses "','") "') ")) ;; interim-qry) + (else (conc " AND " statuses-qry)))) + (else ""))) + (tests-match-qry (tests:match->sqlqry testpatt)) + (qry (conc "SELECT " qryvalstr + (if run-id " FROM tests WHERE run_id=? " - (if last-update " " " AND state != 'DELETED' ") ;; if using last-update we want deleted tests? - states-statuses-qry - (if tests-match-qry (conc " AND (" tests-match-qry ") ") "") - (if last-update (conc " AND last_update >= " last-update " ") "") - (case sort-by - ((rundir) " ORDER BY length(rundir) ") - ((testname) (conc " ORDER BY testname " (if sort-order (conc sort-order ",") "") " item_path ")) - ((statestatus) (conc " ORDER BY state " (if sort-order (conc sort-order ",") "") " status ")) - ((event_time) " ORDER BY event_time ") - (else (if (string? sort-by) - (conc " ORDER BY " sort-by " ") - " "))) - (if sort-order sort-order " ") - (if limit (conc " LIMIT " limit) " ") - (if offset (conc " OFFSET " offset) " ") - ";" - ))) - (debug:print-info 8 *default-log-port* "db:get-tests-for-run run-id=" run-id ", qry=" qry) - (db:with-db dbstruct run-id #f - (lambda (db) - (sqlite3:for-each-row - (lambda (a . b) ;; id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment) - (set! res (cons (apply vector a b) res))) ;; id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment) res))) - db - qry - run-id - ))) - (case qryvals - ((shortlist)(map db:test-short-record->norm res)) - ((#f) res) - (else res))))) + " FROM tests WHERE ? > 0 ") ;; should work? + (if last-update " " " AND state != 'DELETED' ") ;; if using last-update we want deleted tests? + states-statuses-qry + (if tests-match-qry (conc " AND (" tests-match-qry ") ") "") + (if last-update (conc " AND last_update >= " last-update " ") "") + (case sort-by + ((rundir) " ORDER BY length(rundir) ") + ((testname) (conc " ORDER BY testname " (if sort-order (conc sort-order ",") "") " item_path ")) + ((statestatus) (conc " ORDER BY state " (if sort-order (conc sort-order ",") "") " status ")) + ((event_time) " ORDER BY event_time ") + (else (if (string? sort-by) + (conc " ORDER BY " sort-by " ") + " "))) + (if sort-order sort-order " ") + (if limit (conc " LIMIT " limit) " ") + (if offset (conc " OFFSET " offset) " ") + ";" + ))) + (debug:print-info 8 *default-log-port* "db:get-tests-for-run run-id=" run-id ", qry=" qry) + (let* ((res (db:with-db dbstruct run-id #f + (lambda (db) + ;; (let* ((stmth (db:get-cache-stmth dbstruct db qry))) ;; due to use of last-update we can't efficiently cache this query + (reverse + (sqlite3:fold-row + (lambda (res . row) + ;; id run-id testname state status event-time host cpuload + ;; diskfree uname rundir item-path run-duration final-logf comment) + (cons (list->vector row) res)) + '() + db qry ;; stmth + (or run-id 1) ;; 1 > 0 , for the case where we are seeking tests matching criteral for all runs + )))))) + (case qryvals + ((shortlist)(map db:test-short-record->norm res)) + ((#f) res) + (else res))))) (define (db:test-short-record->norm inrec) ;; "id,run_id,testname,item_path,state,status" ;; "id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment (vector (vector-ref inrec 0) ;; id @@ -2273,26 +3119,58 @@ (vector-ref inrec 5) ;; status -1 "" -1 -1 "" "-" (vector-ref inrec 3) ;; item-path -1 "-" "-")) +;; +;; 1. cache tests-match-qry +;; 2. compile qry and store in hash +;; 3. convert for-each-row to fold +;; (define (db:get-tests-for-run-state-status dbstruct run-id testpatt) + (db:with-db + dbstruct run-id #f + (lambda (db) + (let* ((res '()) + (stmt-cache (dbr:dbstruct-stmt-cache dbstruct)) + (stmth (let* ((sh (db:hoh-get stmt-cache db testpatt))) + (or sh + (let* ((tests-match-qry (tests:match->sqlqry testpatt)) + (qry (conc "SELECT id,testname,item_path,state,status FROM tests WHERE run_id=? " + (if tests-match-qry (conc " AND (" tests-match-qry ") ") ""))) + (newsh (sqlite3:prepare db qry))) + (debug:print-info 8 *default-log-port* "db:get-tests-for-run qry=" qry) + (db:hoh-set! stmt-cache db testpatt newsh) + newsh))))) + (reverse + (sqlite3:fold-row + (lambda (res id testname item-path state status) + ;; id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment + (cons (vector id run-id testname state status -1 "" -1 -1 "" "-" item-path -1 "-" "-") res)) + '() + stmth + run-id)))))) + +(define (db:get-tests-for-run-state-status dbstruct run-id testpatt #!optional (last-update 0)) (let* ((res '()) (tests-match-qry (tests:match->sqlqry testpatt)) - (qry (conc "SELECT id,testname,item_path,state,status FROM tests WHERE run_id=? " - (if tests-match-qry (conc " AND (" tests-match-qry ") ") "")))) + (qry (conc "SELECT id,testname,item_path,state,status,event_time,run_duration FROM tests WHERE run_id=? " + " AND last_update > ? " + (if tests-match-qry (conc " AND (" tests-match-qry ") ") "") + ))) (debug:print-info 8 *default-log-port* "db:get-tests-for-run qry=" qry) (db:with-db dbstruct run-id #f (lambda (db) - (sqlite3:for-each-row - (lambda (id testname item-path state status) - ;; id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment - (set! res (cons (vector id run-id testname state status -1 "" -1 -1 "" "-" item-path -1 "-" "-") res))) + (sqlite3:fold-row + (lambda (res id testname item-path state status event-time run-duration) + ;; id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment + (cons (vector id run-id testname state status event-time "" -1 -1 "" "-" item-path run-duration "-" "-") res)) + '() db qry - run-id))) - res)) + run-id + (or last-update 0)))))) (define (db:get-testinfo-state-status dbstruct run-id test-id) (let ((res #f)) (db:with-db dbstruct run-id #f (lambda (db) @@ -2328,29 +3206,33 @@ ;; Convert calling routines to get list of run-ids and loop, do not use the get-tests-for-runs ;; (define (db:delete-test-records dbstruct run-id test-id) - (let* ((dbdat (db:get-db dbstruct run-id)) - (db (db:dbdat-get-db dbdat))) - (db:general-call dbdat 'delete-test-step-records (list test-id)) - ;; (db:delay-if-busy) - (db:general-call dbdat 'delete-test-data-records (list test-id)) - (sqlite3:execute db "UPDATE tests SET state='DELETED',status='n/a',comment='' WHERE id=?;" test-id))) + (db:general-call dbstruct 'delete-test-step-records (list test-id)) + (db:general-call dbstruct 'delete-test-data-records (list test-id)) + (db:with-db + dbstruct #f #f + (lambda (db) + (sqlite3:execute db "UPDATE tests SET state='DELETED',status='n/a',comment='' WHERE id=?;" test-id)))) +;; (define (db:delete-old-deleted-test-records dbstruct) - (let ((run-ids (db:get-all-run-ids dbstruct)) - (targtime (- (current-seconds)(* 30 24 60 60)))) ;; one month in the past - (for-each - (lambda (run-id) - (db:with-db - dbstruct - run-id - #t - (lambda (db) - (sqlite3:execute db "DELETE FROM tests WHERE state='DELETED' AND event_timenumber fieldname fields) (if (null? fields) @@ -2555,44 +3461,48 @@ #f (loop (car tal)(cdr tal)(+ indx 1))))))) (define db:test-record-qry-selector (string-intersperse db:test-record-fields ",")) +(define (db:update-tesdata-on-repilcate-db dbstruct old-lt new-lt) + (db:with-db + dbstruct #f #f + (lambda (db) + (sqlite3:execute db "UPDATE tests SET rundir= replace(rundir,?,?), shortdir=replace(shortdir,?,?);" + old-lt new-lt old-lt new-lt)))) ;; NOTE: Use db:test-get* to access records ;; NOTE: This needs rundir decoding? Decide, decode here or where used? For the moment decode where used. (define (db:get-all-tests-info-by-run-id dbstruct run-id) - (let* ((dbdat (if (vector? dbstruct) - (db:get-db dbstruct run-id) - dbstruct)) ;; still settling on when to use dbstruct or dbdat - (db (db:dbdat-get-db dbdat)) - (res '())) - (db:delay-if-busy dbdat) - (sqlite3:for-each-row - (lambda (id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment shortdir attemptnum archived) - ;; 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 - (set! res (cons (vector id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment shortdir attemptnum archived) - res))) - db - (conc "SELECT " db:test-record-qry-selector " FROM tests WHERE state != 'DELETED' AND run_id=?;") - run-id) + (let* ((res '())) + (db:with-db + dbstruct #f #f + (lambda (db) + (sqlite3:for-each-row + (lambda (id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment shortdir attemptnum archived) + ;; 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 + (set! res (cons (vector id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment shortdir attemptnum archived) + res))) + db + (conc "SELECT " db:test-record-qry-selector " FROM tests WHERE state != 'DELETED' AND run_id=?;") + run-id))) res)) (define (db:replace-test-records dbstruct run-id testrecs) (db:with-db dbstruct run-id #t (lambda (db) (let* ((qmarks (string-intersperse (make-list (length db:test-record-fields) "?") ",")) - (qrystr (conc "INSERT OR REPLACE INTO tests (" db:test-record-qry-selector ") VALUES (" qmarks ");")) + (qrystr (conc "INSERT OR REPLACE INTO tests (" db:test-record-qry-selector ") VALUES (" qmarks ") WHERE run_id=?;")) (qry (sqlite3:prepare db qrystr))) (debug:print 0 *default-log-port* "INFO: migrating test records for run with id " run-id) (sqlite3:with-transaction db (lambda () (for-each (lambda (rec) ;; (debug:print 0 *default-log-port* "INFO: Inserting values: " (string-intersperse (map conc (vector->list rec)) ",") "\n") - (apply sqlite3:execute qry (vector->list rec))) + (apply sqlite3:execute qry (append (vector->list rec)(list run-id)))) testrecs))) (sqlite3:finalize! qry))))) ;; map a test-id into the proper range ;; @@ -2634,22 +3544,23 @@ (lambda (run-id) (let ((testrecs (db:get-all-tests-info-by-run-id mtdb run-id))) (db:prep-megatest.db-adj-test-ids (db:dbdat-get-db mtdb) run-id testrecs))) run-ids))) -;; Get test data using test_id +;; Get test data using test_id, run-id is not used - but it will be! +;; (define (db:get-test-info-by-id dbstruct run-id test-id) (db:with-db dbstruct - run-id + #f ;; run-id #f (lambda (db) (let ((res #f)) (sqlite3:for-each-row ;; attemptnum added to hold pid of top process (not Megatest) controlling a test - (lambda (id run-id testname state status event-time host cpuload diskfree uname rundir-id item-path run_duration final-logf-id comment short-dir-id attemptnum archived) - ;; 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 - (set! res (vector id run-id testname state status event-time host cpuload diskfree uname rundir-id item-path run_duration final-logf-id comment short-dir-id attemptnum archived))) + (lambda (id run-id testname state status event-time host cpuload diskfree uname rundir-id item-path run_duration final-logf-id comment short-dir-id attemptnum archived last-update) + ;; 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 + (set! res (vector id run-id testname state status event-time host cpuload diskfree uname rundir-id item-path run_duration final-logf-id comment short-dir-id attemptnum archived last-update))) db (conc "SELECT " db:test-record-qry-selector " FROM tests WHERE id=?;") test-id) res)))) @@ -2670,11 +3581,11 @@ db (conc "SELECT " db:test-record-qry-selector " FROM tests WHERE id in (" (string-intersperse (map conc test-ids) ",") ");")) res)))) -(define (db:get-test-info dbstruct run-id testname item-path) +(define (db:get-test-info dbstruct run-id test-name item-path) (db:with-db dbstruct run-id #f (lambda (db) @@ -2681,12 +3592,12 @@ (let ((res #f)) (sqlite3:for-each-row (lambda (a . b) (set! res (apply vector a b))) db - (conc "SELECT " db:test-record-qry-selector " FROM tests WHERE testname=? AND item_path=?;") - test-name item-path) + (conc "SELECT " db:test-record-qry-selector " FROM tests WHERE testname=? AND item_path=? AND run_id=?;") + test-name item-path run-id) res)))) (define (db:test-get-rundir-from-test-id dbstruct run-id test-id) (db:with-db dbstruct @@ -2696,10 +3607,44 @@ (db:first-result-default db "SELECT rundir FROM tests WHERE id=?;" #f ;; default result test-id)))) + +(define (db:get-test-times dbstruct run-name target) + (let ((res `()) + (qry (conc "select testname, item_path, run_duration, " (string-join (db:get-keys dbstruct) " || '/' || ") " as target from tests inner join runs on tests.run_id = runs.id where runs.runname = ? and target = ? ;"))) + + (db:with-db + dbstruct + #f ;; this is for the main runs db + #f ;; does not modify db + (lambda (db) + (sqlite3:for-each-row + (lambda (test-name item-path test-time target ) + (set! res (cons (vector test-name item-path test-time) res))) + db + qry + run-name target) + res)))) + +(define (db:get-test-times dbstruct run-name target) + (let ((res `()) + (qry (conc "select testname, item_path, run_duration, " (string-join (db:get-keys dbstruct) " || '/' || ") " as target from tests inner join runs on tests.run_id = runs.id where runs.runname = ? and target = ? ;"))) + + (db:with-db + dbstruct + #f ;; this is for the main runs db + #f ;; does not modify db + (lambda (db) + (sqlite3:for-each-row + (lambda (test-name item-path test-time target ) + (set! res (cons (vector test-name item-path test-time) res))) + db + qry + run-name target) + res)))) ;;====================================================================== ;; S T E P S ;;====================================================================== @@ -2713,11 +3658,26 @@ db "INSERT OR REPLACE into test_steps (test_id,stepname,state,status,event_time,comment,logfile) VALUES(?,?,?,?,?,?,?);" test-id teststep-name state-in status-in (current-seconds) (if comment comment "") (if logfile logfile ""))))) - + + + +(define (db:delete-steps-for-test! dbstruct run-id test-id) + ;; TODO: figure out why status is the key field rather than state (note: CONSTRAINT test_steps_constraint UNIQUE (test_id,stepname,state) ) + (db:with-db + dbstruct + run-id + #t + (lambda (db) + (sqlite3:execute + db + "UPDATE test_steps set status='DELETED' where test_id=?" ;; and run_id=? !! - run_id not in table (bummer) TODO: get run_id into schema for test_steps + test-id)))) + + ;; db-get-test-steps-for-run (define (db:get-steps-for-test dbstruct run-id test-id) (db:with-db dbstruct run-id @@ -2729,10 +3689,25 @@ (set! res (cons (vector id test-id stepname state status event-time (if (string? logfile) logfile "") comment) res))) db "SELECT id,test_id,stepname,state,status,event_time,logfile,comment FROM test_steps WHERE status != 'DELETED' AND test_id=? ORDER BY id ASC;" ;; event_time DESC,id ASC; test-id) (reverse res))))) + + (define (db:get-steps-info-by-id dbstruct test-step-id) + (db:with-db + dbstruct + #f + #f + (lambda (db) + (let* ((res (vector #f #f #f #f #f #f #f #f #f))) + (sqlite3:for-each-row + (lambda (id test-id stepname state status event-time logfile comment last-update) + (set! res (vector id test-id stepname state status event-time (if (string? logfile) logfile "") comment last-update))) + db + "SELECT id,test_id,stepname,state,status,event_time,logfile,comment,last_update FROM test_steps WHERE id=? ORDER BY id ASC;" ;; event_time DESC,id ASC; + test-step-id) + res)))) (define (db:get-steps-data dbstruct run-id test-id) (db:with-db dbstruct run-id @@ -2748,34 +3723,50 @@ (reverse res))))) ;;====================================================================== ;; T E S T D A T A ;;====================================================================== + +(define (db:get-data-info-by-id dbstruct test-data-id) + (let* ((stmt "SELECT id,test_id, category, variable, value, expected, tol, units, comment, status, type, last_update FROM test_data WHERE id=? ORDER BY id ASC;")) ;; event_time DESC,id ASC; + (db:with-db + dbstruct + #f + #f + (lambda (db) + (let* ((stmth (db:get-cache-stmth dbstruct db stmt)) + (res (sqlite3:fold-row + (lambda (res id test-id category variable value expected tol units comment status type last-update) + (vector id test-id category variable value expected tol units comment status type last-update)) + (vector #f #f #f #f #f #f #f #f #f #f #f #f) + stmth + test-data-id))) + res))))) ;; WARNING: Do NOT call this for the parent test on an iterated test ;; Roll up test_data pass/fail results ;; look at the test_data status field, ;; if all are pass (any case) and the test status is PASS or NULL or '' then set test status to PASS. ;; if one or more are fail (any case) then set test status to PASS, non "pass" or "fail" are ignored (define (db:test-data-rollup dbstruct run-id test-id status) - (let* ((dbdat (db:get-db dbstruct run-id)) - (db (db:dbdat-get-db dbdat)) - (fail-count 0) + (let* ((fail-count 0) (pass-count 0)) - (db:delay-if-busy dbdat) - (sqlite3:for-each-row - (lambda (fcount pcount) - (set! fail-count fcount) - (set! pass-count pcount)) - db - "SELECT (SELECT count(id) FROM test_data WHERE test_id=? AND status like 'fail') AS fail_count, + (db:with-db + dbstruct #f #f + (lambda (db) + (sqlite3:for-each-row + (lambda (fcount pcount) + (set! fail-count fcount) + (set! pass-count pcount)) + db + "SELECT (SELECT count(id) FROM test_data WHERE test_id=? AND status like 'fail') AS fail_count, (SELECT count(id) FROM test_data WHERE test_id=? AND status like 'pass') AS pass_count;" - test-id test-id) - ;; Now rollup the counts to the central megatest.db - (db:general-call dbdat 'pass-fail-counts (list pass-count fail-count test-id)) - ;; if the test is not FAIL then set status based on the fail and pass counts. - (db:general-call dbdat 'test_data-pf-rollup (list test-id test-id test-id test-id)))) + test-id test-id) + ;; Now rollup the counts to the central megatest.db + (db:general-call dbstruct 'pass-fail-counts (list pass-count fail-count test-id)) + ;; if the test is not FAIL then set status based on the fail and pass counts. + (db:general-call dbstruct 'test_data-pf-rollup (list test-id test-id test-id test-id)))))) ;; each section is a rule except "final" which is the final result ;; ;; [rule-5] ;; operator in @@ -2822,12 +3813,12 @@ (configf:lookup dat entry-name "message") ;; 4 ;; Comment (configf:lookup dat entry-name "exit-status") ;; 5 ;; Status "logpro" ;; 6 ;; Type )))) (let* ((value (or (configf:lookup dat entry-name "measured") "n/a")) - (expected (or (configf:lookup dat entry-name "expected") "n/a")) - (tolerance (or (configf:lookup dat entry-name "tolerance") "n/a")) + (expected (or (configf:lookup dat entry-name "expected") 0.0)) + (tolerance (or (configf:lookup dat entry-name "tolerance") 0.0)) (comment (or (configf:lookup dat entry-name "comment") (configf:lookup dat entry-name "desc") "n/a")) (status (or (configf:lookup dat entry-name "status") "n/a")) (type (or (configf:lookup dat entry-name "expected") "n/a"))) (set! res (append @@ -2856,119 +3847,139 @@ ;; faz,bar, 10, 8mA, , ,"this is a comment" ;; EOF (define (db:csv->test-data dbstruct run-id test-id csvdata) (debug:print 4 *default-log-port* "test-id " test-id ", csvdata: " csvdata) - (let* ((dbdat (db:get-db dbstruct run-id)) - (db (db:dbdat-get-db dbdat)) - (csvlist (csv->list (make-csv-reader - (open-input-string csvdata) - '((strip-leading-whitespace? #t) - (strip-trailing-whitespace? #t)))))) ;; (csv->list csvdata))) - (for-each - (lambda (csvrow) - (let* ((padded-row (take (append csvrow (list #f #f #f #f #f #f #f #f #f)) 9)) - (category (list-ref padded-row 0)) - (variable (list-ref padded-row 1)) - (value (any->number-if-possible (list-ref padded-row 2))) - (expected (any->number-if-possible (list-ref padded-row 3))) - (tol (any->number-if-possible (list-ref padded-row 4))) ;; >, <, >=, <=, or a number - (units (list-ref padded-row 5)) - (comment (list-ref padded-row 6)) - (status (let ((s (list-ref padded-row 7))) - (if (and (string? s)(or (string-match (regexp "^\\s*$") s) - (string-match (regexp "^n/a$") s))) - #f - s))) ;; if specified on the input then use, else calculate - (type (list-ref padded-row 8))) - ;; look up expected,tol,units from previous best fit test if they are all either #f or '' - (debug:print 4 *default-log-port* "BEFORE: category: " category " variable: " variable " value: " value - ", expected: " expected " tol: " tol " units: " units " status: " status " comment: " comment " type: " type) - - (if (and (or (not expected)(equal? expected "")) - (or (not tol) (equal? expected "")) - (or (not units) (equal? expected ""))) - (let-values (((new-expected new-tol new-units)(tdb:get-prev-tol-for-test #f test-id category variable))) - (set! expected new-expected) - (set! tol new-tol) - (set! units new-units))) - - (debug:print 4 *default-log-port* "AFTER: category: " category " variable: " variable " value: " value - ", expected: " expected " tol: " tol " units: " units " status: " status " comment: " comment) - ;; calculate status if NOT specified - (if (and (not status)(number? expected)(number? value)) ;; need expected and value to be numbers - (if (number? tol) ;; if tol is a number then we do the standard comparison - (let* ((max-val (+ expected tol)) - (min-val (- expected tol)) - (result (and (>= value min-val)(<= value max-val)))) - (debug:print 4 *default-log-port* "max-val: " max-val " min-val: " min-val " result: " result) - (set! status (if result "pass" "fail"))) - (set! status ;; NB// need to assess each one (i.e. not return operator since need to act if not valid op. - (case (string->symbol tol) ;; tol should be >, <, >=, <= - ((>) (if (> value expected) "pass" "fail")) - ((<) (if (< value expected) "pass" "fail")) - ((>=) (if (>= value expected) "pass" "fail")) - ((<=) (if (<= value expected) "pass" "fail")) - (else (conc "ERROR: bad tol comparator " tol)))))) - (debug:print 4 *default-log-port* "AFTER2: category: " category " variable: " variable " value: " value - ", expected: " expected " tol: " tol " units: " units " status: " status " comment: " comment) - (db:delay-if-busy dbdat) - (sqlite3:execute db "INSERT OR REPLACE INTO test_data (test_id,category,variable,value,expected,tol,units,comment,status,type) VALUES (?,?,?,?,?,?,?,?,?,?);" - test-id category variable value expected tol units (if comment comment "") status type))) - csvlist))) + (db:with-db + dbstruct #f #f + (lambda (db) + (let* ((csvlist (csv->list (make-csv-reader + (open-input-string csvdata) + '((strip-leading-whitespace? #t) + (strip-trailing-whitespace? #t)))))) ;; (csv->list csvdata))) + (for-each + (lambda (csvrow) + (let* ((padded-row (take (append csvrow (list #f #f #f #f #f #f #f #f #f)) 9)) + (category (list-ref padded-row 0)) + (variable (list-ref padded-row 1)) + (value (any->number-if-possible (list-ref padded-row 2))) + (expected (any->number-if-possible (list-ref padded-row 3))) + (tol (any->number-if-possible (list-ref padded-row 4))) ;; >, <, >=, <=, or a number + (units (list-ref padded-row 5)) + (comment (list-ref padded-row 6)) + (status (let ((s (list-ref padded-row 7))) + (if (and (string? s)(or (string-match (regexp "^\\s*$") s) + (string-match (regexp "^n/a$") s))) + #f + s))) ;; if specified on the input then use, else calculate + (type (list-ref padded-row 8))) + ;; look up expected,tol,units from previous best fit test if they are all either #f or '' + (debug:print 4 *default-log-port* "BEFORE: category: " category " variable: " variable " value: " value + ", expected: " expected " tol: " tol " units: " units " status: " status " comment: " comment " type: " type) + + (if (and (or (not expected)(equal? expected "")) + (or (not tol) (equal? expected "")) + (or (not units) (equal? expected ""))) + (let-values (((new-expected new-tol new-units)(tdb:get-prev-tol-for-test #f test-id category variable))) + (set! expected new-expected) + (set! tol new-tol) + (set! units new-units))) + + (debug:print 4 *default-log-port* "AFTER: category: " category " variable: " variable " value: " value + ", expected: " expected " tol: " tol " units: " units " status: " status " comment: " comment) + ;; calculate status if NOT specified + (if (and (not status)(number? expected)(number? value)) ;; need expected and value to be numbers + (if (number? tol) ;; if tol is a number then we do the standard comparison + (let* ((max-val (+ expected tol)) + (min-val (- expected tol)) + (result (and (>= value min-val)(<= value max-val)))) + (debug:print 4 *default-log-port* "max-val: " max-val " min-val: " min-val " result: " result) + (set! status (if result "pass" "fail"))) + (set! status ;; NB// need to assess each one (i.e. not return operator since need to act if not valid op. + (case (string->symbol tol) ;; tol should be >, <, >=, <= + ((>) (if (> value expected) "pass" "fail")) + ((<) (if (< value expected) "pass" "fail")) + ((>=) (if (>= value expected) "pass" "fail")) + ((<=) (if (<= value expected) "pass" "fail")) + (else (conc "ERROR: bad tol comparator " tol)))))) + (debug:print 4 *default-log-port* "AFTER2: category: " category " variable: " variable " value: " value + ", expected: " expected " tol: " tol " units: " units " status: " status " comment: " comment) + ;; (db:delay-if-busy dbdat) + (sqlite3:execute db "INSERT OR REPLACE INTO test_data (test_id,category,variable,value,expected,tol,units,comment,status,type) VALUES (?,?,?,?,?,?,?,?,?,?);" + test-id category variable value expected tol units (if comment comment "") status type))) + csvlist))))) ;; This routine moved from tdb.scm, tdb:read-test-data ;; (define (db:read-test-data dbstruct run-id test-id categorypatt) - (let* ((dbdat (db:get-db dbstruct run-id)) - (db (db:dbdat-get-db dbdat)) - (res '())) - (db:delay-if-busy dbdat) - (sqlite3:for-each-row - (lambda (id test_id category variable value expected tol units comment status type) - (set! res (cons (vector id test_id category variable value expected tol units comment status type) res))) - db - "SELECT id,test_id,category,variable,value,expected,tol,units,comment,status,type FROM test_data WHERE test_id=? AND category LIKE ? ORDER BY category,variable;" test-id categorypatt) - (reverse res))) + (let* ((res '())) + (db:with-db + dbstruct #f #f + (lambda (db) + (sqlite3:for-each-row + (lambda (id test_id category variable value expected tol units comment status type) + (set! res (cons (vector id test_id category variable value expected tol units comment status type) res))) + db + "SELECT id,test_id,category,variable,value,expected,tol,units,comment,status,type FROM test_data WHERE test_id=? AND category LIKE ? ORDER BY category,variable;" test-id categorypatt) + (reverse res))))) + +;; This routine moved from tdb.scm, :read-test-data +;; +(define (db:read-test-data* dbstruct run-id test-id categorypatt varpatt) + (let* ((res '())) + (db:with-db + dbstruct #f #f + (lambda (db) + (sqlite3:for-each-row + (lambda (id test_id category variable value expected tol units comment status type) + (set! res (cons (vector id test_id category variable value expected tol units comment status type) res))) + db + "SELECT id,test_id,category,variable,value,expected,tol,units,comment,status,type FROM test_data WHERE test_id=? AND category LIKE ? AND variable LIKE ? ORDER BY category,variable;" test-id categorypatt varpatt) + (reverse res))))) + ;;====================================================================== ;; Misc. test related queries ;;====================================================================== (define (db:get-run-ids-matching-target dbstruct keynames target res runname testpatt statepatt statuspatt) - (let* ((dbdat (db:get-db dbstruct #f)) - (db (db:dbdat-get-db dbdat)) - (row-ids '()) - (keystr (string-intersperse - (map (lambda (key val) - (conc key " like '" val "'")) - keynames - (string-split target "/")) - " AND ")) - ;; (testqry (tests:match->sqlqry testpatt)) - (runsqry (sqlite3:prepare db (conc "SELECT id FROM runs WHERE " keystr " AND runname LIKE '" runname "';")))) - ;; (debug:print 8 *default-log-port* "db:test-get-paths-matching-keynames-target-new\n runsqry=" runsqry "\n tstsqry=" testqry) - (sqlite3:for-each-row - (lambda (rid) - (set! row-ids (cons rid row-ids))) - runsqry) - (sqlite3:finalize! runsqry) - row-ids)) - + (db:with-db + dbstruct #f #f + (lambda (db) + (let* ((row-ids '()) + (keystr (string-intersperse + (map (lambda (key val) + (conc key " like '" val "'")) + keynames + (string-split target "/")) + " AND ")) + ;; (testqry (tests:match->sqlqry testpatt)) + (runsqry (sqlite3:prepare db (conc "SELECT id FROM runs WHERE " keystr " AND runname LIKE '" runname "';")))) + ;; (debug:print 8 *default-log-port* "db:test-get-paths-matching-keynames-target-new\n runsqry=" runsqry "\n tstsqry=" testqry) + (sqlite3:for-each-row + (lambda (rid) + (set! row-ids (cons rid row-ids))) + runsqry) + (sqlite3:finalize! runsqry) + row-ids)))) + +;; finds latest matching all patts for given run-id +;; (define (db:test-get-paths-matching-keynames-target-new dbstruct run-id keynames target res testpatt statepatt statuspatt runname) (let* ((testqry (tests:match->sqlqry testpatt)) - (tstsqry (conc "SELECT rundir FROM tests WHERE " testqry " AND state LIKE '" statepatt "' AND status LIKE '" statuspatt "' ORDER BY event_time ASC;"))) + (tstsqry (conc "SELECT rundir FROM tests WHERE run_id=? AND " testqry " AND state LIKE '" statepatt "' AND status LIKE '" statuspatt "' ORDER BY event_time ASC;"))) (db:with-db dbstruct run-id #f (lambda (db) (sqlite3:for-each-row (lambda (p) (set! res (cons p res))) db - tstsqry) + tstsqry + run-id) res)))) (define (db:test-toplevel-num-items dbstruct run-id testname) (db:with-db dbstruct @@ -2997,14 +4008,14 @@ (string-substitute (regexp "=") "_" (base64:base64-encode (z3:encode-buffer (with-output-to-string - (lambda ()(serialize obj))))) + (lambda ()(serialize obj))))) ;; BB: serialize - this is what causes problems between different builds of megatest communicating. serialize is sensitive to binary image of mtest. #t)) ((zmq nmsg)(with-output-to-string (lambda ()(serialize obj)))) - (else obj))) + (else obj))) ;; rpc (define (db:string->obj msg #!key (transport 'http)) (case transport ;; ((fs) msg) ((http fs) @@ -3014,52 +4025,224 @@ (base64:base64-decode (string-substitute (regexp "_") "=" msg #t))) (lambda ()(deserialize))) (begin - (debug:print-error 0 *default-log-port* "reception failed. Received " msg " but cannot translate it.") + (debug:print-error 0 *default-log-port* "reception failed. Received \"" msg "\" but cannot translate it.") + (print-call-chain (current-error-port)) msg))) ;; crude reply for when things go awry ((zmq nmsg)(with-input-from-string msg (lambda ()(deserialize)))) - (else msg))) - -(define (db:test-set-status-state dbstruct run-id test-id status state msg) - (let ((dbdat (db:get-db dbstruct run-id))) - (if (member state '("LAUNCHED" "REMOTEHOSTSTART")) - (db:general-call dbdat 'set-test-start-time (list test-id))) - (if msg - (db:general-call dbdat 'state-status-msg (list state status msg test-id)) - (db:general-call dbdat 'state-status (list state status test-id))) - (mt:process-triggers run-id test-id state status))) - -;; call with state = #f to roll up with out accounting for state/status of this item -;; -(define (db:roll-up-pass-fail-counts dbstruct run-id test-name item-path state status) - (if (not (equal? item-path "")) - (let ((dbdat (db:get-db dbstruct run-id))) - ;; (db (db:dbdat-get-db dbdat))) - (db:general-call dbdat 'update-pass-fail-counts (list test-name test-name test-name)) - (db:top-test-set-per-pf-counts dbstruct run-id test-name)))) - -;; (case (string->symbol status) -;; ((RUNNING) (db:general-call dbdat 'top-test-set-running (list test-name))) -;; ((LAUNCHED) (db:general-call dbdat 'top-test-set (list "LAUNCHED" test-name))) -;; ((ABORT INCOMPLETE) (db:general-call dbdat 'top-test-set (list status test-name)))) - -;; (if (or (not state) -;; (not (equal? item-path ""))) -;; ;; just do a rollup -;; (begin -;; (db:top-test-set-per-pf-counts dbdat run-id test-name) -;; #f) -;; (begin -;; ;; NOTE: No else clause needed for this case -;; (case (string->symbol status) -;; ((RUNNING) (db:general-call dbdat 'top-test-set-running (list test-name))) -;; ((LAUNCHED) (db:general-call dbdat 'top-test-set (list "LAUNCHED" test-name))) -;; ((ABORT INCOMPLETE) (db:general-call dbdat 'top-test-set (list status test-name)))) -;; #f) -;; ))) + (else msg))) ;; rpc + +;; ; This is to be the big daddy call NOPE: Replaced by db:set-state-status-and-roll-up-items +;; ; +;; define (db:test-set-state-status dbstruct run-id test-id state status msg) +;; (let ((dbdat (db:get-db dbstruct run-id))) +;; (if (member state '("LAUNCHED" "REMOTEHOSTSTART")) +;; (db:general-call dbdat 'set-test-start-time (list test-id))) +;; ;; (if msg +;; ;; (db:general-call dbdat 'state-status-msg (list state status msg test-id)) +;; ;; (db:general-call dbdat 'state-status (list state status test-id))) +;; (db:set-state-status-and-roll-up-items dbstruct run-id test-id #f state status msg) +;; ;; process the test_data table +;; (if (and test-id state status (equal? status "AUTO")) +;; (db:test-data-rollup dbstruct run-id test-id status)) +;; (mt:process-triggers dbstruct run-id test-id state status))) + +;; state is the priority rollup of all states +;; status is the priority rollup of all completed statesfu +;; +;; if test-name is an integer work off that instead of test-name test-path +;; +(define (db:set-state-status-and-roll-up-items dbstruct run-id test-name item-path state status comment) + ;; establish info on incoming test followed by info on top level test + ;; BBnote - for mode itemwait, linkage between upstream test & matching item status is propagated to run queue in db:prereqs-not-met + (let* ((testdat (if (number? test-name) + (db:get-test-info-by-id dbstruct run-id test-name) ;; test-name is actually a test-id + (db:get-test-info dbstruct run-id test-name item-path))) + (test-id (db:test-get-id testdat)) + (test-name (if (number? test-name) + (db:test-get-testname testdat) + test-name)) + (item-path (db:test-get-item-path testdat)) + (tl-testdat (db:get-test-info dbstruct run-id test-name "")) + (tl-test-id (if tl-testdat + (db:test-get-id tl-testdat) + #f))) + (if (member state '("LAUNCHED" "REMOTEHOSTSTART")) + (db:general-call dbstruct 'set-test-start-time (list test-id))) + (mutex-lock! *db-transaction-mutex*) + (db:with-db + dbstruct #f #f + (lambda (db) + (let ((tr-res + (sqlite3:with-transaction + db + (lambda () + ;; NB// Pass the db so it is part fo the transaction + (db:test-set-state-status db run-id test-id state status comment) ;; this call sets the item state/status + (if (not (equal? item-path "")) ;; only roll up IF incoming test is an item + (let* ((state-status-counts (db:get-all-state-status-counts-for-test dbstruct run-id test-name item-path state status)) ;; item-path is used to exclude current state/status of THIS test + (state-stauses (db:roll-up-rules state-status-counts state status)) + (newstate (car state-stauses)) + (newstatus (cadr state-stauses))) + (debug:print 4 *default-log-port* "BB> tl-test-id="tl-test-id" ; "test-name":"item-path" newstate="newstate" newstatus="newstatus" len(sscs)="(length state-status-counts) " state-status-counts: " + (apply conc + (map (lambda (x) + (conc + (with-output-to-string (lambda () (pp (dbr:counts->alist x)))) " | ")) + state-status-counts))); end debug:print + + (if tl-test-id + (db:test-set-state-status db run-id tl-test-id newstate newstatus #f)) ;; we are still in the transaction - must access the db and not the dbstruct + )))))) + (mutex-unlock! *db-transaction-mutex*) + (if (and test-id state status (equal? status "AUTO")) + (db:test-data-rollup dbstruct run-id test-id status)) + tr-res))))) + +(define (db:roll-up-rules state-status-counts state status) + (let* ((running (length (filter (lambda (x) + (member (dbr:counts-state x) *common:running-states*)) + state-status-counts))) + (bad-not-started (length (filter (lambda (x) + (and (equal? (dbr:counts-state x) "NOT_STARTED") + (not (member (dbr:counts-status x) *common:not-started-ok-statuses*)))) + state-status-counts))) + (all-curr-states (common:special-sort ;; worst -> best (sort of) + (delete-duplicates + (if (and state (not (member state *common:dont-roll-up-states*))) + (cons state (map dbr:counts-state state-status-counts)) + (map dbr:counts-state state-status-counts))) + *common:std-states* >)) + (all-curr-statuses (common:special-sort ;; worst -> best + (delete-duplicates + (if (and state status (not (member state *common:dont-roll-up-states*))) + (cons status (map dbr:counts-status state-status-counts)) + (map dbr:counts-status state-status-counts))) + *common:std-statuses* >)) + (non-completes (filter (lambda (x) + (not (member x (cons "COMPLETED" *common:dont-roll-up-states*)))) + all-curr-states)) + (preq-fails (filter (lambda (x) + (equal? x "PREQ_FAIL")) + all-curr-statuses)) + (num-non-completes (length non-completes)) + (newstate (cond + ((> running 0) "RUNNING") ;; anything running, call the situation running + ((> (length preq-fails) 0) "NOT_STARTED") + ((> bad-not-started 0) "COMPLETED") ;; we have an ugly situation, it is completed in the sense we cannot do more. + ((> num-non-completes 0) (car non-completes)) ;; (remove (lambda (x)(equal? "COMPLETED" x)) all-curr-states))) ;; only rollup DELETED if all DELETED + (else (car all-curr-states)))) + (newstatus (cond + ((> (length preq-fails) 0) "PREQ_FAIL") + ((or (> bad-not-started 0) + (and (equal? newstate "NOT_STARTED") + (> num-non-completes 0))) + "STARTED") + (else (car all-curr-statuses))))) + (debug:print-info 2 *default-log-port* + "\n--> probe db:set-state-status-and-roll-up-items: " + "\n--> state-status-counts: "(map dbr:counts->alist state-status-counts) + "\n--> running: "running + "\n--> bad-not-started: "bad-not-started + "\n--> non-non-completes: "num-non-completes + "\n--> non-completes: "non-completes + "\n--> all-curr-states: "all-curr-states + "\n--> all-curr-statuses: "all-curr-statuses + "\n--> newstate "newstate + "\n--> newstatus "newstatus + "\n\n") + + ;; NB// Pass the db so it is part of the transaction + (list newstate newstatus))) + +(define (db:set-state-status-and-roll-up-run dbstruct run-id curr-state curr-status) + (mutex-lock! *db-transaction-mutex*) + (db:with-db + dbstruct #f #f + (lambda (db) + (let ((tr-res + (sqlite3:with-transaction + db + (lambda () + (let* ((state-status-counts (db:get-all-state-status-counts-for-run dbstruct run-id)) + (state-stauses (db:roll-up-rules state-status-counts #f #f )) + (newstate (car state-stauses)) + (newstatus (cadr state-stauses))) + (if (or (not (eq? newstate curr-state)) (not (eq? newstatus curr-status))) + (db:set-run-state-status dbstruct run-id newstate newstatus ))))))) + (mutex-unlock! *db-transaction-mutex*) + tr-res)))) + + +(define (db:get-all-state-status-counts-for-run dbstruct run-id) + (let* ((test-count-recs (db:with-db + dbstruct #f #f + (lambda (db) + (sqlite3:map-row + (lambda (state status count) + (make-dbr:counts state: state status: status count: count)) + db + "SELECT state,status,count(id) FROM tests WHERE run_id=? GROUP BY state,status;" + run-id ))))) + test-count-recs)) + + +;; BBnote: db:get-all-state-status-counts-for-test returns dbr:counts object aggregating state and status of items of a given test, *not including rollup state/status* +;; +;; NOTE: This is called within a transaction +;; +(define (db:get-all-state-status-counts-for-test dbstruct run-id test-name item-path item-state-in item-status-in) + (let* ((test-info (db:get-test-info dbstruct run-id test-name item-path)) + (item-state (or item-state-in (db:test-get-state test-info))) + (item-status (or item-status-in (db:test-get-status test-info))) + (other-items-count-recs (db:with-db + dbstruct #f #f + (lambda (db) + (sqlite3:map-row + (lambda (state status count) + (make-dbr:counts state: state status: status count: count)) + db + ;; ignore current item because we have changed its value in the current transation so this select will see the old value. + "SELECT state,status,count(id) FROM tests WHERE run_id=? AND testname=? AND item_path != '' AND item_path !=? GROUP BY state,status;" + run-id test-name item-path)))) + + ;; add current item to tally outside of sql query + (match-countrec-lambda (lambda (countrec) + (and (equal? (dbr:counts-state countrec) item-state) + (equal? (dbr:counts-status countrec) item-status)))) + + (already-have-count-rec-list + (filter match-countrec-lambda other-items-count-recs)) ;; will have either 0 or 1 count recs depending if another item shares this item's state/status + + (updated-count-rec (if (null? already-have-count-rec-list) + (make-dbr:counts state: item-state status: item-status count: 1) + (let* ((our-count-rec (car already-have-count-rec-list)) + (new-count (add1 (dbr:counts-count our-count-rec)))) + (make-dbr:counts state: item-state status: item-status count: new-count)))) + + (nonmatch-countrec-lambda (lambda (countrec) (not (match-countrec-lambda countrec)))) + + (unrelated-rec-list + (filter nonmatch-countrec-lambda other-items-count-recs))) + + (cons updated-count-rec unrelated-rec-list))) + +;; (define (db:get-all-item-states db run-id test-name) +;; (sqlite3:map-row +;; (lambda (a) a) +;; db +;; "SELECT DISTINCT state FROM tests WHERE item_path != '' AND state != 'DELETED' AND run_id=? AND testname=?" +;; run-id test-name)) +;; +;; (define (db:get-all-item-statuses db run-id test-name) +;; (sqlite3:map-row +;; (lambda (a) a) +;; db +;; "SELECT DISTINCT status FROM tests WHERE item_path != '' AND state != 'DELETED' AND state='COMPLETED' AND run_id=? AND testname=?" +;; run-id test-name)) (define (db:test-get-logfile-info dbstruct run-id test-name) (db:with-db dbstruct run-id @@ -3074,12 +4257,12 @@ (set! res (list path final_logf)) (if (directory? path) (debug:print 2 *default-log-port* "Found path: " path) (debug:print 2 *default-log-port* "No such path: " path))) ;; ) db - "SELECT rundir,final_logf FROM tests WHERE testname=? AND item_path='';" - test-name) + "SELECT rundir,final_logf FROM tests WHERE testname=? AND item_path='' AND run_id=?;" + test-name run-id) res)))) ;;====================================================================== ;; A G R E G A T E D T R A N S A C T I O N D B W R I T E S ;;====================================================================== @@ -3090,11 +4273,11 @@ ;; TESTS '(register-test "INSERT OR IGNORE INTO tests (run_id,testname,event_time,item_path,state,status) VALUES (?,?,strftime('%s','now'),?,'NOT_STARTED','n/a');") ;; Test state and status '(set-test-state "UPDATE tests SET state=? WHERE id=?;") '(set-test-status "UPDATE tests SET state=? WHERE id=?;") - '(state-status "UPDATE tests SET state=?,status=? WHERE id=?;") ;; DONE + '(state-status "UPDATE tests SET state=?,status=? WHERE id=?;") ;; D/ONE '(state-status-msg "UPDATE tests SET state=?,status=?,comment=? WHERE id=?;") ;; DONE ;; Test comment '(set-test-comment "UPDATE tests SET comment=? WHERE id=?;") '(set-test-start-time "UPDATE tests SET event_time=strftime('%s','now') WHERE id=?;") ;; DONE '(pass-fail-counts "UPDATE tests SET pass_count=?,fail_count=? WHERE id=?;") @@ -3108,27 +4291,28 @@ ELSE status END WHERE id=?;") ;; DONE '(test-set-log "UPDATE tests SET final_logf=? WHERE id=?;") ;; DONE ;; '(test-set-rundir-by-test-id "UPDATE tests SET rundir=? WHERE id=?") ;; DONE ;; '(test-set-rundir "UPDATE tests SET rundir=? AND testname=? AND item_path=?;") ;; DONE - '(test-set-rundir-shortdir "UPDATE tests SET rundir=?,shortdir=? WHERE testname=? AND item_path=?;") + '(test-set-rundir-shortdir "UPDATE tests SET rundir=?,shortdir=? WHERE testname=? AND item_path=? AND run_id=?;") ;; BROKEN!!! NEEDS run-id '(delete-tests-in-state ;; "DELETE FROM tests WHERE state=?;") ;; DONE "UPDATE tests SET state='DELETED' WHERE state=?") '(tests:test-set-toplog "UPDATE tests SET final_logf=? WHERE run_id=? AND testname=? AND item_path='';") '(update-cpuload-diskfree "UPDATE tests SET cpuload=?,diskfree=? WHERE id=?;") ;; DONE '(update-uname-host "UPDATE tests SET uname=?,host=? WHERE id=?;") ;; DONE + '(update-test-rundat "INSERT INTO test_rundat (test_id,update_time,cpuload,diskfree,diskusage,run_duration) VALUES (?,?,?,?,?,?);") '(update-test-state "UPDATE tests SET state=? WHERE state=? AND run_id=? AND testname=? AND NOT (item_path='' AND testname IN (SELECT DISTINCT testname FROM tests WHERE testname=? AND item_path != ''));") '(update-test-status "UPDATE tests SET status=? WHERE status like ? AND run_id=? AND testname=? AND NOT (item_path='' AND testname IN (SELECT DISTINCT testname FROM tests WHERE testname=? AND item_path != ''));") - ;; stuff for roll-up-pass-fail-counts + ;; stuff for set-state-status-and-roll-up-items '(update-pass-fail-counts "UPDATE tests SET fail_count=(SELECT count(id) FROM tests WHERE testname=? AND item_path != '' AND status IN ('FAIL','CHECK','INCOMPLETE','ABORT')), pass_count=(SELECT count(id) FROM tests WHERE testname=? AND item_path != '' AND status IN ('PASS','WARN','WAIVED')) - WHERE testname=? AND item_path='';") ;; DONE - '(top-test-set "UPDATE tests SET state=? WHERE testname=? AND item_path='';") ;; DONE - '(top-test-set-running "UPDATE tests SET state='RUNNING' WHERE testname=? AND item_path='';") ;; DONE + WHERE testname=? AND item_path='' AND run_id=?;") ;; DONE ;; BROKEN!!! NEEDS run-id + '(top-test-set-running "UPDATE tests SET state='RUNNING' WHERE testname=? AND item_path='' AND run_id=?;") ;; DONE ;; BROKEN!!! NEEDS run-id - + ;; NOT USED + ;; ;; Might be the following top-test-set-per-pf-counts query could be better based off of something like this: ;; ;; select state,status,count(state) from tests where run_id=59 AND testname='runfirst' group by state,status; ;; '(top-test-set-per-pf-counts "UPDATE tests @@ -3212,11 +4396,11 @@ AND item_path != '' AND state = 'COMPLETED' AND status = 'PASS') > 0 THEN 'PASS' WHEN pass_count > 0 AND fail_count=0 THEN 'PASS' ELSE 'UNKNOWN' END - WHERE testname=? AND item_path='';") ;; DONE + WHERE testname=? AND item_path='';") ;; DONE ;; BROKEN!!! NEEDS run-id ;; STEPS '(delete-test-step-records "UPDATE test_steps SET status='DELETED' WHERE test_id=?;") '(delete-test-data-records "UPDATE test_data SET status='DELETED' WHERE test_id=?;") ;; using status since no state field )) @@ -3225,59 +4409,72 @@ (let ((q (alist-ref qry-name db:queries))) (if q (car q) #f))) ;; do not run these as part of the transaction (define db:special-queries '(rollup-tests-pass-fail - ;; db:roll-up-pass-fail-counts ;; WHY NOT!? + ;; db:set-state-status-and-roll-up-items ;; WHY NOT!? login immediate flush sync set-verbosity killserver )) -(define (db:login dbstruct calling-path calling-version run-id client-signature) +(define (db:login dbstruct calling-path calling-version client-signature) (cond ((not (equal? calling-path *toppath*)) (list #f "Login failed due to mismatch paths: " calling-path ", " *toppath*)) - ((not (equal? *run-id* run-id)) - (list #f "Login failed due to mismatch run-id: " run-id ", " *run-id*)) + ;; ((not (equal? *run-id* run-id)) + ;; (list #f "Login failed due to mismatch run-id: " run-id ", " *run-id*)) ((not (equal? megatest-version calling-version)) - (list #f "Login failed due to mismatch megatest version: " calling-version ", " megatest-version)) + (list #t (conc "Login warning due to mismatch megatest version: " calling-version ", " megatest-version))) (else (hash-table-set! *logged-in-clients* client-signature (current-seconds)) '(#t "successful login")))) -(define (db:general-call dbdat stmtname params) +(define (db:general-call dbstruct stmtname params) (let ((query (let ((q (alist-ref (if (string? stmtname) (string->symbol stmtname) stmtname) db:queries))) (if q (car q) #f)))) - (db:delay-if-busy dbdat) - (apply sqlite3:execute (db:dbdat-get-db dbdat) query params) - #t)) + (db:with-db + dbstruct #f #f + (lambda (db) + (apply sqlite3:execute db query params) + #t)))) ;; get a summary of state and status counts to calculate a rollup ;; -;; NOTE: takes a db, not a dbstruct -;; -(define (db:get-state-status-summary db run-id testname) +(define (db:get-state-status-summary dbstruct run-id testname) (let ((res '())) - (sqlite3:for-each-row - (lambda (state status count) - (set! res (cons (vector state status count) res))) - db - "SELECT state,status,count(state) FROM tests WHERE run_id=? AND testname=? AND item_path='' GROUP BY state,status;" - run-id testname) - res)) + (db:with-db + dbstruct #f #f + (lambda (db) + (sqlite3:for-each-row + (lambda (state status count) + (set! res (cons (vector state status count) res))) + db + "SELECT state,status,count(state) FROM tests WHERE run_id=? AND testname=? AND item_path='' GROUP BY state,status;" + run-id testname) + res)))) + +(define (db:get-latest-host-load dbstruct raw-hostname) + (let* ((hostname (string-substitute "\\..*$" "" raw-hostname)) + (res (cons -1 0))) + (db:with-db + dbstruct #f #f + (lambda (db) + (sqlite3:for-each-row + (lambda (cpuload update-time) (set! res (cons cpuload update-time))) + db + "SELECT tr.cpuload, tr.update_time FROM test_rundat tr, tests t WHERE t.host=? AND tr.cpuload != -1 AND tr.test_id=t.id ORDER BY tr.update_time DESC LIMIT 1;" + hostname))) res )) (define (db:set-top-level-from-items dbstruct run-id testname) - (let* ((dbdat (db:get-db dbstruct run-id)) - (db (db:dbdat-get-db dbdat)) - (summ (db:get-state-status-summary db run-id testname)) + (let* ((summ (db:get-state-status-summary dbstruct run-id testname)) (find (lambda (state status) (if (null? summ) #f (let loop ((hed (car summ)) (tal (cdr summ))) @@ -3302,32 +4499,35 @@ ;; can use wildcards. Also can likely be factored in with get test paths? ;; ;; Run this remotely!! ;; (define (db:get-matching-previous-test-run-records dbstruct run-id test-name item-path) - (let* ((dbdat (db:get-db dbstruct #f)) - (db (db:dbdat-get-db dbdat)) - (keys (db:get-keys db)) + (let* ((keys (db:get-keys dbstruct)) (selstr (string-intersperse keys ",")) (qrystr (string-intersperse (map (lambda (x)(conc x "=?")) keys) " AND ")) (keyvals #f) (tests-hash (make-hash-table))) ;; first look up the key values from the run selected by run-id - (db:delay-if-busy dbdat) - (sqlite3:for-each-row - (lambda (a . b) - (set! keyvals (cons a b))) - db - (conc "SELECT " selstr " FROM runs WHERE id=? ORDER BY event_time DESC;") run-id) + (db:with-db + dbstruct #f #f + (lambda (db) + (sqlite3:for-each-row + (lambda (a . b) + (set! keyvals (cons a b))) + db + (conc "SELECT " selstr " FROM runs WHERE id=? ORDER BY event_time DESC;") run-id))) (if (not keyvals) '() (let ((prev-run-ids '())) - (apply sqlite3:for-each-row - (lambda (id) - (set! prev-run-ids (cons id prev-run-ids))) - db - (conc "SELECT id FROM runs WHERE " qrystr " AND id != ?;") (append keyvals (list run-id))) + (db:with-db + dbstruct #f #f + (lambda (db) + (apply sqlite3:for-each-row + (lambda (id) + (set! prev-run-ids (cons id prev-run-ids))) + db + (conc "SELECT id FROM runs WHERE " qrystr " AND id != ?;") (append keyvals (list run-id))))) ;; collect all matching tests for the runs then ;; extract the most recent test and return that. (debug:print 4 *default-log-port* "selstr: " selstr ", qrystr: " qrystr ", keyvals: " keyvals ", previous run ids found: " prev-run-ids) (if (null? prev-run-ids) '() ;; no previous runs? return null @@ -3349,24 +4549,27 @@ results) (if (null? tal) (map cdr (hash-table->alist tests-hash)) ;; return a list of the most recent tests (loop (car tal)(cdr tal)))))))))) +;; Function recursively checks if .journal exists; if yes means db busy; call itself after delayed interval +;; return the sqlite3 db handle if possible +;; (define (db:delay-if-busy dbdat #!key (count 6)) - (if (not (configf:lookup *configdat* "server" "delay-on-busy")) + (if (not (configf:lookup *configdat* "server" "delay-on-busy")) (and dbdat (db:dbdat-get-db dbdat)) (if dbdat (let* ((dbpath (db:dbdat-get-path dbdat)) (db (db:dbdat-get-db dbdat)) ;; we'll return this so (db:delay--if-busy can be called inline (dbfj (conc dbpath "-journal"))) (if (handle-exceptions exn (begin - (debug:print-info 0 *default-log-port* "WARNING: failed to test for existance of " dbfj) + (debug:print-info 0 *default-log-port* "WARNING: failed to test for existance of " dbfj ", exn=" exn) (thread-sleep! 1) - (db:delay-if-busy count (- count 1))) - (file-exists? dbfj)) + (db:delay-if-busy count (- count 1))) + (common:file-exists? dbfj)) (case count ((6) (thread-sleep! 0.2) (db:delay-if-busy count: 5)) ((5) @@ -3385,11 +4588,11 @@ (thread-sleep! 6.4) (db:delay-if-busy count: 0)) (else (debug:print-info 0 *default-log-port* "delaying db access due to high database load.") (thread-sleep! 12.8)))) - db) + db) "bogus result from db:delay-if-busy"))) (define (db:test-get-records-for-index-file dbstruct run-id test-name) (let ((res '())) (db:with-db @@ -3399,17 +4602,38 @@ (lambda (db) (sqlite3:for-each-row (lambda (id itempath state status run_duration logf comment) (set! res (cons (vector id itempath state status run_duration logf comment) res))) db - "SELECT id,item_path,state,status,run_duration,final_logf,comment FROM tests WHERE testname=? AND item_path != '';" - test-name) + "SELECT id,item_path,state,status,run_duration,final_logf,comment FROM tests WHERE testname=? AND item_path != '' AND run_id=?;" ;; BUG! WHY NO run_id? + test-name + run-id) res)))) ;;====================================================================== ;; Tests meta data ;;====================================================================== + +;; returns a hash table of tags to tests +;; +(define (db:get-tests-tags dbstruct) + (db:with-db + dbstruct #f #f + (lambda (db) + (let* ((res (make-hash-table))) + (sqlite3:for-each-row + (lambda (testname tags-in) + (let ((tags (string-split tags-in ","))) + (for-each + (lambda (tag) + (hash-table-set! res tag + (delete-duplicates + (cons testname (hash-table-ref/default res tag '()))))) + tags))) + db + "SELECT testname,tags FROM test_meta") + (hash-table->alist res))))) ;; read the record given a testname (define (db:testmeta-get-record dbstruct testname) (let ((res #f)) (db:with-db @@ -3494,95 +4718,246 @@ (let loop ((hed (car all-patts)) (tal (cdr all-patts)) (res item-path)) (let* ((parts (string-split hed)) (patt (car parts)) + (repl (if (> (length parts) 1)(cadr parts) "")) + (newr (if (and patt repl) - (string-substitute patt repl res) + (begin + (handle-exceptions + exn + (begin + (debug:print 0 *default-log-port* + "WARNING: itemmap has problem \"" itemmap "\", patt: " patt ", repl: " repl ", exn=" exn) + res) + (string-substitute patt repl res)) + + + ) (begin - (debug:print 0 *default-log-port* "WARNING: itemmap has problem \"" itemmap "\", patt: " patt ", repl: " repl) + (debug:print 0 *default-log-port* + "WARNING: itemmap has problem \"" itemmap "\", patt: " patt ", repl: " repl) res)))) (if (null? tal) newr (loop (car tal)(cdr tal) newr))))))) + + + ;; the new prereqs calculation, looks also at itempath if specified ;; all prereqs must be met ;; if prereq test with itempath='' is COMPLETED and PASS, WARN, CHECK, or WAIVED then prereq is met ;; if prereq test with itempath=ref-item-path and COMPLETED with PASS, WARN, CHECK, or WAIVED then prereq is met ;; ;; Note: mode 'normal means that tests must be COMPLETED and ok (i.e. PASS, WARN, CHECK, SKIP or WAIVED) ;; mode 'toplevel means that tests must be COMPLETED only ;; mode 'itemmatch or 'itemwait means that tests items must be COMPLETED and (PASS|WARN|WAIVED|CHECK) [[ NB// NOT IMPLEMENTED YET ]] +;; mode 'exclusive means this test/item cannot run if the same test/item is LAUNCHED,REMOTEHOSTSTART or RUNNING +;; +;; IDEA for consideration: +;; 1. collect all tests "upstream" +;; 2. any NOT completed and good? if yes => return those as prereqs not met, if no => return null list ;; ;; (define (db:get-prereqs-not-met dbstruct run-id waitons ref-item-path mode) (define (db:get-prereqs-not-met dbstruct run-id waitons ref-test-name ref-item-path mode itemmaps) ;; #!key (mode '(normal))(itemmap #f)) - (if (or (not waitons) - (null? waitons)) - '() - (let* ((unmet-pre-reqs '()) - (result '())) - (for-each - (lambda (waitontest-name) - ;; by getting the tests with matching name we are looking only at the matching test - ;; and related sub items - ;; next should be using mt:get-tests-for-run? - (let ((tests (db:get-tests-for-run-state-status dbstruct run-id waitontest-name)) - (ever-seen #f) - (parent-waiton-met #f) - (item-waiton-met #f)) - (for-each - (lambda (test) - ;; (if (equal? waitontest-name (db:test-get-testname test)) ;; by defintion this had better be true ... - (let* ((state (db:test-get-state test)) - (status (db:test-get-status test)) - (item-path (db:test-get-item-path test)) - (is-completed (equal? state "COMPLETED")) - (is-running (equal? state "RUNNING")) - (is-killed (equal? state "KILLED")) - (is-ok (member status '("PASS" "WARN" "CHECK" "WAIVED" "SKIP"))) - ;; testname-b path-a path-b - (same-itempath (db:compare-itempaths ref-test-name item-path ref-item-path itemmaps))) ;; (equal? ref-item-path item-path))) - (set! ever-seen #t) - (cond - ;; case 1, non-item (parent test) is - ((and (equal? item-path "") ;; this is the parent test of the waiton being examined - is-completed - (or is-ok (not (null? (lset-intersection eq? mode '(toplevel)))))) ;; itemmatch itemwait)))))) - (set! parent-waiton-met #t)) - ;; Special case for toplevel and KILLED - ((and (equal? item-path "") ;; this is the parent test - is-killed - (member 'toplevel mode)) - (set! parent-waiton-met #t)) - ;; For itemwait mode IFF the previous matching item is good the set parent-waiton-met - ((and (not (null? (lset-intersection eq? mode '(itemmatch itemwait)))) ;; how is that different from (member mode '(itemmatch itemwait)) ????? - ;; (not (equal? item-path "")) ;; this applies to both top level (to allow launching of next batch) and items - same-itempath) - (if (and is-completed is-ok) - (set! item-waiton-met #t)) - (if (and (equal? item-path "") - (or is-completed is-running));; this is the parent, set it to run if completed or running - (set! parent-waiton-met #t))) - ;; normal checking of parent items, any parent or parent item not ok blocks running - ((and is-completed - (or is-ok - (member 'toplevel mode)) ;; toplevel does not block on FAIL - (and is-ok (member 'itemmatch mode))) ;; itemmatch blocks on not ok - (set! item-waiton-met #t))))) - tests) - ;; both requirements, parent and item-waiton must be met to NOT add item to - ;; prereq's not met list - (if (not (or parent-waiton-met item-waiton-met)) - (set! result (append (if (null? tests) (list waitontest-name) tests) result))) - ;; if the test is not found then clearly the waiton is not met... - ;; (if (not ever-seen)(set! result (cons waitontest-name result))))) - (if (not ever-seen) - (set! result (append (if (null? tests)(list waitontest-name) tests) result))))) - waitons) - (delete-duplicates result)))) + ;; BBnote - rollup of an itemized test's overall state/status done in db:set-state-status-and-roll-up-items + (append + (if (member 'exclusive mode) + (let ((running-tests (db:get-tests-for-run dbstruct + #f ;; run-id of #f means for all runs. + (if (string=? ref-item-path "") ;; testpatt + ref-test-name + (conc ref-test-name "/" ref-item-path)) + '("LAUNCHED" "REMOTEHOSTSTART" "RUNNING") ;; states + '() ;; statuses + #f ;; offset + #f ;; limit + #f ;; not-in + #f ;; sort by + #f ;; sort order + 'shortlist ;; query type + 0 ;; last update, beginning of time .... + #f ;; mode + ))) + ;;(map (lambda (testdat) + ;; (if (equal? (db:test-get-item-path testdat) "") + ;; (db:test-get-testname testdat) + ;; (conc (db:test-get-testname testdat) + ;; "/" + ;; (db:test-get-item-path testdat)))) + running-tests) ;; calling functions want the entire data + '()) + + ;; collection of: for each waiton - + ;; if this ref-test-name is an item in an itemized test and mode is itemwait/itemmatch: + ;; if waiton is not itemized - if waiton is not both completed and in ok status, add as unmet prerequisite + ;; if waiton is itemized: + ;; and waiton's items are not expanded, add as unmet prerequisite + ;; else if matching waiton item is not both completed and in an ok status, add as unmet prerequisite + ;; else + ;; if waiton toplevel is not in both completed and ok status, add as unmet prerequisite + + (if (or (not waitons) + (null? waitons)) + '() + (let* ((ref-test-itemized-mode (not (null? (lset-intersection eq? mode '(itemmatch itemwait))))) ;; how is this different from using member? + (ref-test-toplevel-mode (not (null? (lset-intersection eq? mode '(toplevel))))) + (ref-test-is-toplevel (equal? ref-item-path "")) + (ref-test-is-item (not ref-test-is-toplevel)) + (unmet-pre-reqs '()) + (result '()) + (unmet-prereq-items '()) + ) + (for-each ; waitons + (lambda (waitontest-name) + ;; by getting the tests with matching name we are looking only at the matching test + ;; and related sub items + ;; next should be using mt:get-tests-for-run? + + (let (;(waiton-is-itemized ...) + ;(waiton-items-are-expanded ...) + (waiton-tests (db:get-tests-for-run-state-status dbstruct run-id waitontest-name)) + (ever-seen #f) + (parent-waiton-met #f) + (item-waiton-met #f) + + ) + (for-each ; test expanded from waiton + (lambda (waiton-test) + (let* ((waiton-state (db:test-get-state waiton-test)) + (waiton-status (db:test-get-status waiton-test)) + (waiton-item-path (db:test-get-item-path waiton-test)) ;; BB- this is the upstream itempath + (waiton-test-name (db:test-get-testname waiton-test)) + (waiton-is-toplevel (equal? waiton-item-path "")) + (waiton-is-item (not waiton-is-toplevel)) + (waiton-is-completed (member waiton-state *common:ended-states*)) + (waiton-is-running (member waiton-state *common:running-states*)) + (waiton-is-killed (member waiton-state *common:badly-ended-states*)) + (waiton-is-ok (member waiton-status *common:well-ended-states*)) + ;; testname-b path-a path-b + (same-itempath (db:compare-itempaths ref-test-name waiton-item-path ref-item-path itemmaps)) ;; (equal? ref-item-path waiton-item-path))) + (real-ref-test-name (car (string-split ref-test-name "/"))) ;; I THINK ref-test-name SHOULD NEVER HAVE THE ITEM_PATH! + (test-and-ref-are-same (equal? real-ref-test-name waiton-test-name))) + (debug:print 4 *default-log-port* "waiton-test-name " waiton-test-name " ref-test-name: " ref-test-name " test-and-ref-are-same: " test-and-ref-are-same) + (set! ever-seen #t) + ;;(BB> "***consider waiton "waiton-test"/"waiton-item-path"***") + (cond + ;; case 0 - toplevel of an itemized test, at least one item in prereq has completed + ((and waiton-is-item ref-test-is-toplevel ref-test-itemized-mode waiton-is-completed) + (set! parent-waiton-met #t)) + + ;; case 1, non-item (parent test) is + ((and waiton-is-toplevel ;; this is the parent test of the waiton being examined + waiton-is-completed + ;;(BB> "cond1") + (or waiton-is-ok ref-test-toplevel-mode)) ;; itemmatch itemwait)))))) + (set! parent-waiton-met #t)) + ;; Special case for toplevel and KILLED + ((and waiton-is-toplevel ;; this is the parent test + waiton-is-killed + (member 'toplevel mode)) + ;;(BB> "cond2") + (set! parent-waiton-met #t)) + ;; For itemwait mode IFF the previous matching item is good the set parent-waiton-met + ((and ref-test-itemized-mode ref-test-is-item same-itempath) + ;;(BB> "cond3") + (if (and waiton-is-completed (or waiton-is-ok ref-test-toplevel-mode)) + (set! item-waiton-met #t) + (set! unmet-prereq-items (cons waiton-test unmet-prereq-items))) + (if (and waiton-is-toplevel ;; if upstream rollup test is completed, parent-waiton-met is set + (or waiton-is-completed waiton-is-running)) + (set! parent-waiton-met #t))) + ;; normal checking of parent items, any parent or parent item not ok blocks running + ((and waiton-is-completed + (or waiton-is-ok + (member 'toplevel mode)) ;; toplevel does not block on FAIL + (and waiton-is-ok (member 'itemmatch mode) ;; itemmatch blocks on not ok ;; TODO: THIS IS PROBABLY A BUG. ITEMMATCH AND ITEMWAIT ARE SYNONYMS!! WHAT HAPPENED OT ITEMWAIT??? + )) + ;;(BB> "cond4") + (set! item-waiton-met #t)) + ((and waiton-is-completed waiton-is-ok same-itempath) + ;;(BB> "cond5") + (set! item-waiton-met #t)) + ((and waiton-is-completed waiton-is-ok test-and-ref-are-same) ;; probably from [waitons] table + (set! item-waiton-met #t)) + (else + #t + ;;(BB> "condelse") + )))) + waiton-tests) + ;; both requirements, parent and item-waiton must be met to NOT add item to + ;; prereq's not met list + ;; (BB> + ;; "\n* waiton-tests "waiton-tests + ;; "\n* parent-waiton-met "parent-waiton-met + ;; "\n* item-waiton-met "item-waiton-met + ;; "\n* ever-seen "ever-seen + ;; "\n* ref-test-itemized-mode "ref-test-itemized-mode + ;; "\n* unmet-prereq-items "unmet-prereq-items + ;; "\n* result (pre) "result + ;; "\n* ever-seen "ever-seen + ;; "\n") + + (cond + ((and ref-test-itemized-mode ref-test-is-item (not (null? unmet-prereq-items))) + (set! result (append unmet-prereq-items result))) + ((not (or parent-waiton-met item-waiton-met)) + (set! result (append (if (null? waiton-tests) (list waitontest-name) waiton-tests) result))) ;; appends the string if the full record is not available + ;; if the test is not found then clearly the waiton is not met... + ;; (if (not ever-seen)(set! result (cons waitontest-name result))))) + ((not ever-seen) + (set! result (append (if (null? waiton-tests)(list waitontest-name) waiton-tests) result)))))) + waitons) + (delete-duplicates result))))) + +;;====================================================================== +;; To sync individual run +;;====================================================================== +(define (db:get-run-record-ids dbstruct target run keynames test-patt) +(let ((backcons (lambda (lst item)(cons item lst)))) + (db:with-db + dbstruct #f #f + (lambda (db) + (let* ((keystr (string-intersperse + (map (lambda (key val) + (conc key " like '" val "'")) + keynames + (string-split target "/")) + " AND ")) + (run-qry (conc "SELECT id FROM runs WHERE " keystr " and runname='" run"'")) + (test-qry (conc "SELECT id FROM tests WHERE run_id in (" run-qry ") and testname like '" test-patt "'"))) + (print run-qry) + (print test-qry) + `((runs . ,(sqlite3:fold-row backcons '() db run-qry)) + (tests . ,(sqlite3:fold-row backcons '() db test-qry)) + (test_steps . ,(sqlite3:fold-row backcons '() db (conc "SELECT id FROM test_steps WHERE test_id in (" test-qry ")"))) + (test_data . ,(sqlite3:fold-row backcons '() db (conc "SELECT id FROM test_data WHERE test_id in (" test-qry ")" ))) + )))))) + +;;====================================================================== +;; Just for sync, procedures to make sync easy +;;====================================================================== + +;; get an alist of record ids changed since time since-time +;; '((runs . (1 2 3 ...))(steps . (5 6 7 ...) ...)) +;; +(define (db:get-changed-record-ids dbstruct since-time) + ;; no transaction, allow the db to be accessed between the big queries + (let ((backcons (lambda (lst item)(cons item lst)))) + (db:with-db + dbstruct #f #f + (lambda (db) + `((runs . ,(sqlite3:fold-row backcons '() db "SELECT id FROM runs WHERE last_update>=?" since-time)) + (tests . ,(sqlite3:fold-row backcons '() db "SELECT id FROM tests WHERE last_update>=?" since-time)) + (test_steps . ,(sqlite3:fold-row backcons '() db "SELECT id FROM test_steps WHERE last_update>=?" since-time)) + (test_data . ,(sqlite3:fold-row backcons '() db "SELECT id FROM test_data WHERE last_update>=?" since-time)) + ;; (test_meta . ,(fold-row backcons '() db "SELECT id FROM test_meta WHERE last_update>?" since-time)) + (run_stats . ,(sqlite3:fold-row backcons '() db "SELECT id FROM run_stats WHERE last_update>=?" since-time)) + ))))) ;;====================================================================== ;; Extract ods file from the db ;;====================================================================== @@ -3593,11 +4968,11 @@ (define (db:extract-ods-file dbstruct outputfile keypatt-alist runspatt pathmod) (let* ((keysstr (string-intersperse (map car keypatt-alist) ",")) (keyqry (string-intersperse (map (lambda (p)(conc (car p) " LIKE ? ")) keypatt-alist) " AND ")) (numkeys (length keypatt-alist)) (test-ids '()) - (dbdat (db:get-db dbstruct #f)) + (dbdat (db:get-db dbstruct)) (db (db:dbdat-get-db dbdat)) (windows (and pathmod (substring-index "\\" pathmod))) (tempdir (conc "/tmp/" (current-user-name) "/" runspatt "_" (random 10000) "_" (current-process-id))) (runsheader (append (list "Run Id" "Runname") ; 0 1 (map car keypatt-alist) ; + N = length keypatt-alist @@ -3657,12 +5032,12 @@ (testname (vector-ref vb (+ 2 numkeys))) (item-path (vector-ref vb (+ 3 numkeys))) (final-log (vector-ref vb (+ 7 numkeys))) (run-dir (vector-ref vb (+ 18 numkeys))) (log-fpath (conc run-dir "/" final-log))) ;; (string-intersperse keyvals "/") "/" testname "/" item-path "/" - (debug:print 4 *default-log-port* "log: " log-fpath " exists: " (file-exists? log-fpath)) - (vector-set! vb (+ 7 numkeys) (if (file-exists? log-fpath) + (debug:print 4 *default-log-port* "log: " log-fpath " exists: " (common:file-exists? log-fpath)) + (vector-set! vb (+ 7 numkeys) (if (common:file-exists? log-fpath) (let ((newpath (conc pathmod "/" (string-intersperse keyvals "/") "/" runname "/" testname "/" (if (string=? item-path "") "" (conc "/" item-path)) final-log))) @@ -3705,10 +5080,11 @@ (begin (debug:print 0 *default-log-port* "WARNING: path given, " outputfile " is relative, prefixing with current directory") (conc (current-directory) "/" outputfile))) results) ;; brutal clean up + (stack-push! (dbr:dbstruct-dbstack dbstruct) dbdat) (system "rm -rf tempdir"))) ;; (db:extract-ods-file db "outputfile.ods" '(("sysname" "%")("fsname" "%")("datapath" "%")) "%") Index: db_records.scm ================================================================== --- db_records.scm +++ db_records.scm @@ -1,5 +1,22 @@ +;; Copyright 2006-2017, Matthew Welland. +;; +;; This file is part of Megatest. +;; +;; Megatest is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. +;; +;; Megatest is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with Megatest. If not, see . + ;;====================================================================== ;; dbstruct ;;====================================================================== ;; @@ -13,59 +30,61 @@ ;; ;; ;; Accessors for a dbstruct ;; -(define-inline (dbr:dbstruct-get-main vec) (vector-ref vec 0)) ;; ( db path ) -(define-inline (dbr:dbstruct-get-strdb vec) (vector-ref vec 1)) ;; ( db path ) -(define-inline (dbr:dbstruct-get-path vec) (vector-ref vec 2)) -(define-inline (dbr:dbstruct-get-local vec) (vector-ref vec 3)) -(define-inline (dbr:dbstruct-get-rundb vec) (vector-ref vec 4)) ;; ( db path ) -(define-inline (dbr:dbstruct-get-inmem vec) (vector-ref vec 5)) ;; ( db #f ) -(define-inline (dbr:dbstruct-get-mtime vec) (vector-ref vec 6)) -(define-inline (dbr:dbstruct-get-rtime vec) (vector-ref vec 7)) -(define-inline (dbr:dbstruct-get-stime vec) (vector-ref vec 8)) -(define-inline (dbr:dbstruct-get-inuse vec) (vector-ref vec 9)) -(define-inline (dbr:dbstruct-get-refdb vec) (vector-ref vec 10)) ;; ( db path ) -(define-inline (dbr:dbstruct-get-locdbs vec) (vector-ref vec 11)) -(define-inline (dbr:dbstruct-get-olddb vec) (vector-ref vec 12)) ;; ( db path ) -;; (define-inline (dbr:dbstruct-get-main-path vec) (vector-ref vec 13)) -;; (define-inline (dbr:dbstruct-get-rundb-path vec) (vector-ref vec 14)) -;; (define-inline (dbr:dbstruct-get-run-id vec) (vector-ref vec 13)) - -(define-inline (dbr:dbstruct-set-main! vec val)(vector-set! vec 0 val)) -(define-inline (dbr:dbstruct-set-strdb! vec val)(vector-set! vec 1 val)) -(define-inline (dbr:dbstruct-set-path! vec val)(vector-set! vec 2 val)) -(define-inline (dbr:dbstruct-set-local! vec val)(vector-set! vec 3 val)) -(define-inline (dbr:dbstruct-set-rundb! vec val)(vector-set! vec 4 val)) -(define-inline (dbr:dbstruct-set-inmem! vec val)(vector-set! vec 5 val)) -(define-inline (dbr:dbstruct-set-mtime! vec val)(vector-set! vec 6 val)) -(define-inline (dbr:dbstruct-set-rtime! vec val)(vector-set! vec 7 val)) -(define-inline (dbr:dbstruct-set-stime! vec val)(vector-set! vec 8 val)) -(define-inline (dbr:dbstruct-set-inuse! vec val)(vector-set! vec 9 val)) -(define-inline (dbr:dbstruct-set-refdb! vec val)(vector-set! vec 10 val)) -(define-inline (dbr:dbstruct-set-locdbs! vec val)(vector-set! vec 11 val)) -(define-inline (dbr:dbstruct-set-olddb! vec val)(vector-set! vec 12 val)) -(define-inline (dbr:dbstruct-set-main-path! vec val)(vector-set! vec 13 val)) -(define-inline (dbr:dbstruct-set-rundb-path! vec val)(vector-set! vec 14 val)) - -; (define-inline (dbr:dbstruct-set-run-id! vec val)(vector-set! vec 13 val)) +;; (define-inline (dbr:dbstruct-main vec) (vector-ref vec 0)) ;; ( db path ) +;; (define-inline (dbr:dbstruct-strdb vec) (vector-ref vec 1)) ;; ( db path ) +;; (define-inline (dbr:dbstruct-path vec) (vector-ref vec 2)) +;; (define-inline (dbr:dbstruct-local vec) (vector-ref vec 3)) +;; (define-inline (dbr:dbstruct-rundb vec) (vector-ref vec 4)) ;; ( db path ) +;; (define-inline (dbr:dbstruct-inmem vec) (vector-ref vec 5)) ;; ( db #f ) +;; (define-inline (dbr:dbstruct-mtime vec) (vector-ref vec 6)) +;; (define-inline (dbr:dbstruct-rtime vec) (vector-ref vec 7)) +;; (define-inline (dbr:dbstruct-stime vec) (vector-ref vec 8)) +;; (define-inline (dbr:dbstruct-inuse vec) (vector-ref vec 9)) +;; (define-inline (dbr:dbstruct-refdb vec) (vector-ref vec 10)) ;; ( db path ) +;; (define-inline (dbr:dbstruct-locdbs vec) (vector-ref vec 11)) +;; (define-inline (dbr:dbstruct-olddb vec) (vector-ref vec 12)) ;; ( db path ) +;; ;; (define-inline (dbr:dbstruct-main-path vec) (vector-ref vec 13)) +;; ;; (define-inline (dbr:dbstruct-rundb-path vec) (vector-ref vec 14)) +;; ;; (define-inline (dbr:dbstruct-run-id vec) (vector-ref vec 13)) +;; +;; (define-inline (dbr:dbstruct-main-set! vec val)(vector-set! vec 0 val)) +;; (define-inline (dbr:dbstruct-strdb-set! vec val)(vector-set! vec 1 val)) +;; (define-inline (dbr:dbstruct-path-set! vec val)(vector-set! vec 2 val)) +;; (define-inline (dbr:dbstruct-local-set! vec val)(vector-set! vec 3 val)) +;; (define-inline (dbr:dbstruct-rundb-set! vec val)(vector-set! vec 4 val)) +;; (define-inline (dbr:dbstruct-inmem-set! vec val)(vector-set! vec 5 val)) +;; (define-inline (dbr:dbstruct-mtime-set! vec val)(vector-set! vec 6 val)) +;; (define-inline (dbr:dbstruct-rtime-set! vec val)(vector-set! vec 7 val)) +;; (define-inline (dbr:dbstruct-stime-set! vec val)(vector-set! vec 8 val)) +;; (define-inline (dbr:dbstruct-inuse-set! vec val)(vector-set! vec 9 val)) +;; (define-inline (dbr:dbstruct-refdb-set! vec val)(vector-set! vec 10 val)) +;; (define-inline (dbr:dbstruct-locdbs-set! vec val)(vector-set! vec 11 val)) +;; (define-inline (dbr:dbstruct-olddb-set! vec val)(vector-set! vec 12 val)) +;; (define-inline (dbr:dbstruct-main-path-set! vec val)(vector-set! vec 13 val)) +;; (define-inline (dbr:dbstruct-rundb-path-set! vec val)(vector-set! vec 14 val)) +;; +; (define-inline (dbr:dbstruct-run-id-set! vec val)(vector-set! vec 13 val)) ;; constructor for dbstruct ;; -(define (make-dbr:dbstruct #!key (path #f)(local #f)) - (let ((v (make-vector 15 #f))) - (dbr:dbstruct-set-path! v path) - (dbr:dbstruct-set-local! v local) - (dbr:dbstruct-set-locdbs! v (make-hash-table)) - v)) - -(define (dbr:dbstruct-get-localdb v run-id) - (hash-table-ref/default (dbr:dbstruct-get-locdbs v) run-id #f)) - -(define (dbr:dbstruct-set-localdb! v run-id db) - (hash-table-set! (dbr:dbstruct-get-locdbs v) run-id db)) +;; (define (make-dbr:dbstruct #!key (path #f)(local #f)) +;; (let ((v (make-vector 15 #f))) +;; (dbr:dbstruct-path-set! v path) +;; (dbr:dbstruct-local-set! v local) +;; (dbr:dbstruct-locdbs-set! v (make-hash-table)) +;; v)) + +;; Returns the database for a particular run-id fron the dbstruct:localdbs +;; +(define (dbr:dbstruct-localdb v run-id) + (hash-table-ref/default (dbr:dbstruct-locdbs v) run-id #f)) + +(define (dbr:dbstruct-localdb-set! v run-id db) + (hash-table-set! (dbr:dbstruct-locdbs v) run-id db)) (define (make-db:test)(make-vector 20)) (define-inline (db:test-get-id vec) (vector-ref vec 0)) (define-inline (db:test-get-run_id vec) (vector-ref vec 1)) @@ -83,10 +102,11 @@ (define-inline (db:test-get-run_duration vec) (vector-ref vec 12)) (define-inline (db:test-get-final_logf vec) (vector-ref vec 13)) (define-inline (db:test-get-comment vec) (vector-ref vec 14)) (define-inline (db:test-get-process_id vec) (vector-ref vec 16)) (define-inline (db:test-get-archived vec) (vector-ref vec 17)) +(define-inline (db:test-get-last_update vec) (vector-ref vec 18)) ;; (define-inline (db:test-get-pass_count vec) (vector-ref vec 15)) ;; (define-inline (db:test-get-fail_count vec) (vector-ref vec 16)) (define-inline (db:test-get-fullname vec) (conc (db:test-get-testname vec) "/" (db:test-get-item-path vec))) @@ -94,11 +114,11 @@ ;; replace runs:make-full-test-name with this routine (define (db:test-make-full-name testname itempath) (if (equal? itempath "") testname (conc testname "/" itempath))) (define-inline (db:test-get-first_err vec) (printable (vector-ref vec 15))) -(define-inline (db:test-get-first_warn vec) (printable (vector-ref vec 16))) +(define-inline (db:test-get-first_warn vec) (printable (vector-ref vec 16))) ;; RADT => reference 16 is repeated (define-inline (db:test-set-cpuload! vec val)(vector-set! vec 7 val)) (define-inline (db:test-set-diskfree! vec val)(vector-set! vec 8 val)) (define-inline (db:test-set-testname! vec val)(vector-set! vec 2 val)) (define-inline (db:test-set-state! vec val)(vector-set! vec 3 val)) @@ -113,10 +133,11 @@ (define (db:test-get-is-toplevel vec) (and (equal? (db:test-get-item-path vec) "") ;; test is not an item (equal? (db:test-get-uname vec) "n/a"))) ;; test has never been run ;; make-vector-record "" db mintest id run_id testname state status event_time item_path +;; RADT => purpose of mintest?? ;; (define (make-db:mintest)(make-vector 7)) (define-inline (db:mintest-get-id vec) (vector-ref vec 0)) (define-inline (db:mintest-get-run_id vec) (vector-ref vec 1)) (define-inline (db:mintest-get-testname vec) (vector-ref vec 2)) @@ -144,10 +165,16 @@ (define-inline (db:testmeta-set-description! vec val)(vector-set! vec 4 val)) (define-inline (db:testmeta-set-reviewed! vec val)(vector-set! vec 5 val)) (define-inline (db:testmeta-set-iterated! vec val)(vector-set! vec 6 val)) (define-inline (db:testmeta-set-avg_runtime! vec val)(vector-set! vec 7 val)) (define-inline (db:testmeta-set-avg_disk! vec val)(vector-set! vec 8 val)) + +;;====================================================================== +;; S I M P L E R U N +;;====================================================================== + +;; (defstruct id "runname" "state" "status" "owner" "event_time" ;;====================================================================== ;; T E S T D A T A ;;====================================================================== (define (make-db:test-data)(make-vector 10)) @@ -160,10 +187,11 @@ (define-inline (db:test-data-get-tol vec) (vector-ref vec 6)) (define-inline (db:test-data-get-units vec) (vector-ref vec 7)) (define-inline (db:test-data-get-comment vec) (vector-ref vec 8)) (define-inline (db:test-data-get-status vec) (vector-ref vec 9)) (define-inline (db:test-data-get-type vec) (vector-ref vec 10)) +(define-inline (db:test-data-get-last_update vec) (vector-ref vec 11)) (define-inline (db:test-data-set-id! vec val)(vector-set! vec 0 val)) (define-inline (db:test-data-set-test_id! vec val)(vector-set! vec 1 val)) (define-inline (db:test-data-set-category! vec val)(vector-set! vec 2 val)) (define-inline (db:test-data-set-variable! vec val)(vector-set! vec 3 val)) @@ -178,27 +206,28 @@ ;;====================================================================== ;; S T E P S ;;====================================================================== ;; Run steps ;; make-vector-record "Run steps" db step id test_id stepname step_complete step_pass event_time -(define (make-db:step)(make-vector 7)) +(define (make-db:step)(make-vector 9)) (define-inline (tdb:step-get-id vec) (vector-ref vec 0)) (define-inline (tdb:step-get-test_id vec) (vector-ref vec 1)) (define-inline (tdb:step-get-stepname vec) (vector-ref vec 2)) (define-inline (tdb:step-get-state vec) (vector-ref vec 3)) (define-inline (tdb:step-get-status vec) (vector-ref vec 4)) (define-inline (tdb:step-get-event_time vec) (vector-ref vec 5)) (define-inline (tdb:step-get-logfile vec) (vector-ref vec 6)) (define-inline (tdb:step-get-comment vec) (vector-ref vec 7)) +(define-inline (tdb:step-get-last_update vec) (vector-ref vec 8)) (define-inline (tdb:step-set-id! vec val)(vector-set! vec 0 val)) (define-inline (tdb:step-set-test_id! vec val)(vector-set! vec 1 val)) (define-inline (tdb:step-set-stepname! vec val)(vector-set! vec 2 val)) (define-inline (tdb:step-set-state! vec val)(vector-set! vec 3 val)) (define-inline (tdb:step-set-status! vec val)(vector-set! vec 4 val)) (define-inline (tdb:step-set-event_time! vec val)(vector-set! vec 5 val)) (define-inline (tdb:step-set-logfile! vec val)(vector-set! vec 6 val)) -(define-inline (tdb:step-set-comment! vec vak)(vector-set! vec 7 val)) +(define-inline (tdb:step-set-comment! vec val)(vector-set! vec 7 val)) ;; The steps table (define (make-db:steps-table)(make-vector 5)) (define-inline (tdb:steps-table-get-stepname vec) (vector-ref vec 0)) ADDED dbmod.scm Index: dbmod.scm ================================================================== --- /dev/null +++ dbmod.scm @@ -0,0 +1,39 @@ +;;====================================================================== +;; Copyright 2017, Matthew Welland. +;; +;; This file is part of Megatest. +;; +;; Megatest is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. +;; +;; Megatest is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with Megatest. If not, see . + +;;====================================================================== + +(declare (unit dbmod)) + +(module dbmod + * + +(import scheme chicken data-structures extras) +(import (prefix sqlite3 sqlite3:) posix typed-records srfi-18) + +(define (just-testing) + (print "JUST TESTING")) + +;; (define (debug:print . params) #f) +;; (define (debug:print-info . params) #f) +;; +;; (define (set-functions dbgp dbgpinfo) +;; (set! debug:print dbgp) +;; (set! debug:print-info dbgpinfo)) + +) DELETED dbwars/NOTES Index: dbwars/NOTES ================================================================== --- dbwars/NOTES +++ /dev/null @@ -1,31 +0,0 @@ -Before using prepare: - -matt@xena:/tmp/megatest/dbwars$ ./sqlite3-test insert -Adding 1047 test3 item/39 host0-0.3-200000-240-this one sucks eh? (added 51886 records so far) -Adding 1122 test5 item/52 host2-0.2-200000-120-this is a good one eh? (added 78889 records so far) -Adding 1050 test7 item/31 host1-0.1-100000-120-this is a good one eh? (added 110641 records so far) -create-tests ran register-test 144000 times in 41.0 seconds - -After using prepare: - -matt@xena:/tmp/megatest/dbwars$ csc sqlite3-test.scm && ./sqlite3-test insert -Adding 1082 test4 item/74 host1-0.3-100000-120-this is a good one eh? (added 61281 records so far) -Adding 1138 test7 item/43 host2-0.3-200000-120-this is a good one eh? (added 109001 records so far) -Adding 1023 test9 item/00 host0-0.2-100000-240-this one sucks eh? (added 143878 records so far) -create-tests ran register-test 144000 times in 38.0 seconds - -After moving the prepare outside the call (so it isn't done each time): - -matt@xena:/tmp/megatest/dbwars$ ./sqlite3-test insert -Adding 1042 test4 item/59 host0-0.3-200000-120-this is a good one eh? (added 63401 records so far) -Adding 1011 test6 item/40 host0-0.1-200000-120-this one sucks eh? (added 94906 records so far) -Adding 1076 test9 item/34 host1-0.2-200000-120-just eh, eh? (added 139035 records so far) -create-tests ran register-test 144000 times in 33.0 seconds - -Using sql-de-lite with very similar code: - -matt@xena:/tmp/megatest/dbwars$ ./sql-de-lite-test insert -Adding 1029 test4 item/53 host0-0.2-200000-240- (added 64252 records so far) -Adding 1134 test7 item/64 host2-0.3-100000-240-this is a good one eh? (added 105973 records so far) -create-tests ran register-test 144000 times in 31.0 seconds - DELETED dbwars/sql-de-lite-test.scm Index: dbwars/sql-de-lite-test.scm ================================================================== --- dbwars/sql-de-lite-test.scm +++ /dev/null @@ -1,19 +0,0 @@ - -(use sql-de-lite) -(include "test-common.scm") - -(define db (open-database "test.db")) - -(exec (sql db test-table-defn)) -(exec (sql db syncsetup)) - -(define (register-test stmth run-id testname host cpuload diskfree uname rundir shortdir item-path state status final-logf run-duration comment event-time) - (exec - stmth ;; (sql db test-insert) - run-id - testname host cpuload diskfree uname rundir shortdir item-path state status final-logf run-duration comment event-time)) - -(let ((stmth (sql db test-insert))) - (create-tests stmth)) - -(close-database db) DELETED dbwars/sqlite3-test.scm Index: dbwars/sqlite3-test.scm ================================================================== --- dbwars/sqlite3-test.scm +++ /dev/null @@ -1,20 +0,0 @@ - -(use sqlite3) -(include "test-common.scm") - -(define db (open-database "test.db")) - -(execute db test-table-defn) -(execute db syncsetup) - - -(define (register-test stmth run-id testname host cpuload diskfree uname rundir shortdir item-path state status final-logf run-duration comment event-time) - (execute stmth - run-id - testname host cpuload diskfree uname rundir shortdir item-path state status final-logf run-duration comment event-time)) - -(let ((stmth (prepare db test-insert))) - (create-tests stmth) - (finalize! stmth)) - -(finalize! db) DELETED dbwars/test-common.scm Index: dbwars/test-common.scm ================================================================== --- dbwars/test-common.scm +++ /dev/null @@ -1,129 +0,0 @@ -(use srfi-18 srfi-69 apropos) - -(define args (argv)) - -(if (not (eq? (length args) 2)) - (begin - (print "Usage: sqlitecompare [insert|update]") - (exit 0))) - -(define action (string->symbol (cadr args))) - -(system "rm -f test.db") - -(define test-table-defn - "CREATE TABLE IF NOT EXISTS tests - (id INTEGER PRIMARY KEY, - run_id INTEGER, - testname TEXT, - host TEXT DEFAULT 'n/a', - cpuload REAL DEFAULT -1, - diskfree INTEGER DEFAULT -1, - uname TEXT DEFAULT 'n/a', - rundir TEXT DEFAULT 'n/a', - shortdir TEXT DEFAULT '', - item_path TEXT DEFAULT '', - state TEXT DEFAULT 'NOT_STARTED', - status TEXT DEFAULT 'FAIL', - attemptnum INTEGER DEFAULT 0, - final_logf TEXT DEFAULT 'logs/final.log', - logdat BLOB, - run_duration INTEGER DEFAULT 0, - comment TEXT DEFAULT '', - event_time TIMESTAMP, - fail_count INTEGER DEFAULT 0, - pass_count INTEGER DEFAULT 0, - archived INTEGER DEFAULT 0, -- 0=no, 1=in progress, 2=yes - CONSTRAINT testsconstraint UNIQUE (run_id, testname, item_path) - );") - -(define test-insert "INSERT INTO tests (run_id,testname,host,cpuload,diskfree,uname,rundir,shortdir,item_path,state,status,final_logf,run_duration,comment,event_time) - values (?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ? );") -(define syncsetup "PRAGMA synchronous = OFF;") - -(define tests '("test0" "test1" "test2" "test3" "test4" "test5" "test6" "test7" "test8" "test9")) -(define items '()) -(for-each - (lambda (n) - (for-each - (lambda (m) - (set! items (cons (conc "item/" n m) items))) - '(0 1 2 3 4 5 6 7 8 9))) - '(0 1 2 3 4 5 6 7 8 9)) -(define hosts '("host0" "host1" "host2")) ;; "host3" "host4" "host5" "host6" "host7" "host8" "host9")) -(define cpuloads '(0.1 0.2 0.3)) ;; 0.4 0.5 0.6 0.7 0.8 0.9)) -(define diskfrees '(100000 200000)) ;; 300000 400000 500000 600000 700000 800000 900000)) -(define uname "Linux xena 3.5.0-40-generic #62~precise1-Ubuntu SMP Fri Aug 23 17:59:10 UTC 2013 i686 i686 i386 GNU/Linux") -(define basedir "/mfs/matt/data/megatest/runs/testing") -(define final-logf "finallog.html") -(define run-durations (list 120 240)) ;; 260)) -(define comments '("" "this is a good one eh?" "this one sucks eh?" "just eh, eh?")) - -(define run-ids (make-hash-table)) -(define max-run-id 1000) - -(define (test-factors->run-id host cpuload diskfree run-duration comment) - (let* ((factor (conc host "-" cpuload "-" diskfree "-" run-duration "-" comment)) - (run-id (hash-table-ref/default run-ids factor #f))) - (if run-id - (list run-id factor) - (let ((new-id (+ max-run-id 1))) - (set! max-run-id new-id) - (hash-table-set! run-ids factor new-id) - (list new-id factor))))) - - -(define (create-tests stmth) - (let ((num-created 0) - (last-print (current-seconds)) - (start-time (current-seconds))) - (for-each - (lambda (test) - (for-each - (lambda (item) - (for-each - (lambda (host) - (for-each - (lambda (cpuload) - (for-each - (lambda (diskfree) - (for-each - (lambda (run-duration) - (for-each - (lambda (comment) - (let* ((run-id-dat (test-factors->run-id host cpuload diskfree run-duration comment)) - (run-id (car run-id-dat)) - (factor (cadr run-id-dat)) - (curr-time (current-seconds))) - (if (> (- curr-time last-print) 10) - (begin - (print "Adding " run-id " " test " " item " " factor " (added " num-created " records so far)") - (set! last-print curr-time))) - (set! num-created (+ num-created 1)) - (register-test stmth ;; db - run-id - test ;; testname - host - cpuload - diskfree - uname - (conc basedir "/" test "/" item) ;; rundir - (conc test "/" item) ;; shortdir - item ;; item-path - "NOT_STARTED" ;; state - "NA" ;; status - final-logf - run-duration - comment - (current-seconds)))) - comments)) - run-durations)) - diskfrees)) - cpuloads)) - hosts)) - items)) - tests) - (print "create-tests ran register-test " num-created " times in " (- (current-seconds) start-time) " seconds"))) - - - Index: dcommon.scm ================================================================== --- dcommon.scm +++ dcommon.scm @@ -1,42 +1,117 @@ ;;====================================================================== ;; Copyright 2006-2013, Matthew Welland. ;; -;; This program is made available under the GNU GPL version 2.0 or -;; greater. See the accompanying file COPYING for details. +;; This file is part of Megatest. +;; +;; Megatest is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. +;; +;; Megatest is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. ;; -;; This program is distributed WITHOUT ANY WARRANTY; without even the -;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR -;; PURPOSE. +;; You should have received a copy of the GNU General Public License +;; along with Megatest. If not, see . +;; ;;====================================================================== (use format) (require-library iup) (import (prefix iup iup:)) (use canvas-draw) (import canvas-draw-iup) -(use regex defstruct) +(use regex typed-records matchable) (declare (unit dcommon)) -(declare (uses megatest-version)) (declare (uses gutils)) (declare (uses db)) -(declare (uses synchash)) +;; (declare (uses synchash)) +(include "megatest-version.scm") (include "common_records.scm") (include "db_records.scm") (include "key_records.scm") +(include "run_records.scm") ;; yes, this is non-ideal (define dashboard:update-summary-tab #f) (define dashboard:update-servers-table #f) ;;====================================================================== ;; C O M M O N D A T A S T R U C T U R E ;;====================================================================== ;; +;; data common to all tabs goes here +;; +(defstruct dboard:commondat + ((curr-tab-num 0) : number) + please-update + tabdats + update-mutex + updaters + updating + uidat ;; needs to move to tabdat at some time + hide-not-hide-tabs + ) + +(define (dboard:commondat-make) + (make-dboard:commondat + curr-tab-num: 0 + tabdats: (make-hash-table) + please-update: #t + update-mutex: (make-mutex) + updaters: (make-hash-table) + updating: #f + hide-not-hide-tabs: #f + )) + +;; RADT => Matrix defstruct addition +(defstruct dboard:graph-dat + ((id #f) : string) + ((color #f) : vector) + ((flag #t) : boolean) + ((cell #f) : number) + ) + +;; data for runs, tests etc. was used in run summary? +;; +(defstruct dboard:runsdat + ;; new system + runs-index ;; target/runname => colnum + tests-index ;; testname/itempath => rownum + matrix-dat ;; vector of vectors rows/cols + ) + +(define (dboard:runsdat-make-init) + (make-dboard:runsdat + runs-index: (make-hash-table) + tests-index: (make-hash-table) + matrix-dat: (make-sparse-array))) + +;; used to keep the rundata from rmt:get-tests-for-run +;; in sync. +;; +(defstruct dboard:rundat + run + tests-drawn ;; list of id's already drawn on screen + tests-notdrawn ;; list of id's NOT already drawn + rowsused ;; hash of lists covering what areas used - replace with quadtree + hierdat ;; put hierarchial sorted list here + tests ;; hash of id => testdat + ((tests-by-name (make-hash-table)) : hash-table) ;; hash of testfullname => testdat + key-vals + ((last-update 0) : number) ;; last query to db got records from before last-update + ((last-db-time 0) : number) ;; last timestamp on megatest.db + ((data-changed #f) : boolean) + ((run-data-offset 0) : number) ;; get only 100 items per call, set back to zero when received less than 100 items + (db-path #f)) + ;;====================================================================== ;; D O T F I L E ;;====================================================================== @@ -71,11 +146,11 @@ ;; (define (dcommon:modifiy-if-different mtrx cell-name new-val prev-changed) (let ((curr-val (iup:attribute mtrx cell-name))) (if (not (equal? curr-val new-val)) (begin - (iup:attribute-set! mtrx cell-name col-name) + (iup:attribute-set! mtrx cell-name new-val) ;; was col-name #t) ;; need a re-draw prev-changed))) ;; TO-DO @@ -84,185 +159,220 @@ ;; 3. Add extraction of filters to synchash calls ;; ;; NOTE: Used in newdashboard ;; ;; Mode is 'full or 'incremental for full refresh or incremental refresh -(define (dcommon:run-update keys data runname keypatts testpatt states statuses mode window-id) - (let* (;; count and offset => #f so not used - ;; the synchash calls modify the "data" hash - (changed #f) - (get-runs-sig (conc (client:get-signature) " get-runs")) - (get-tests-sig (conc (client:get-signature) " get-tests")) - (get-details-sig (conc (client:get-signature) " get-test-details")) - - ;; test-ids to get and display are indexed on window-id in curr-test-ids hash - (test-ids (hash-table-values (dboard:tabdat-curr-test-ids data))) - ;; run-id is #f in next line to send the query to server 0 - (run-changes (synchash:client-get 'db:get-runs get-runs-sig (length keypatts) data #f runname #f #f keypatts)) - (tests-detail-changes (if (not (null? test-ids)) - (synchash:client-get 'db:get-test-info-by-ids get-details-sig 0 data #f test-ids) - '())) - - ;; Now can calculate the run-ids - (run-hash (hash-table-ref/default data get-runs-sig #f)) - (run-ids (if run-hash (filter number? (hash-table-keys run-hash)) '())) - - (all-test-changes (let ((res (make-hash-table))) - (for-each (lambda (run-id) - (if (> run-id 0) - (hash-table-set! res run-id (synchash:client-get 'db:get-tests-for-run-mindata get-tests-sig 0 data run-id 1 testpatt states statuses #f)))) - run-ids) - res)) - (runs-hash (hash-table-ref/default data get-runs-sig #f)) - (header (hash-table-ref/default runs-hash "header" #f)) - (run-ids (sort (filter number? (hash-table-keys runs-hash)) - (lambda (a b) - (let* ((record-a (hash-table-ref runs-hash a)) - (record-b (hash-table-ref runs-hash b)) - (time-a (db:get-value-by-header record-a header "event_time")) - (time-b (db:get-value-by-header record-b header "event_time"))) - (> time-a time-b))) - )) - (runid-to-col (hash-table-ref *cachedata* "runid-to-col")) - (testname-to-row (hash-table-ref *cachedata* "testname-to-row")) - (colnum 1) - (rownum 0) - (cellname (conc rownum ":" colnum))) ;; rownum = 0 is the header -;; (debug:print 0 *default-log-port* "test-ids " test-ids ", tests-detail-changes " tests-detail-changes) - - ;; tests related stuff - ;; (all-testnames (delete-duplicates (map db:test-get-testname test-changes)))) - - ;; Given a run-id and testname/item_path calculate a cell R:C - - ;; NOTE: Also build the test tree browser and look up table - ;; - ;; Each run is unique on its keys and runname or run-id, store in hash on colnum - (for-each (lambda (run-id) - (let* ((run-record (hash-table-ref/default runs-hash run-id #f)) - (key-vals (map (lambda (key)(db:get-value-by-header run-record header key)) - keys)) - (run-name (db:get-value-by-header run-record header "runname")) - (col-name (conc (string-intersperse key-vals "\n") "\n" run-name)) - (run-path (append key-vals (list run-name)))) - (hash-table-set! (dboard:tabdat-run-keys data) run-id run-path) - ;; modify cell - but only if changed - (set! changed (dcommon:modifiy-if-different (dboard:tabdat-runs-matrix data) cellname col-name changed)) - (hash-table-set! runid-to-col run-id (list colnum run-record)) - ;; Here we update the tests treebox and tree keys - (tree:add-node (dboard:tabdat-tests-tree data) "Runs" (append key-vals (list run-name)) - userdata: (conc "run-id: " run-id)) - (set! colnum (+ colnum 1)))) - run-ids) - - ;; Scan all tests to be displayed and organise all the test names, respecting what is in the hash table - ;; Do this analysis in the order of the run-ids, the most recent run wins - (for-each (lambda (run-id) - (let* ((run-path (hash-table-ref (dboard:tabdat-run-keys data) run-id)) - (test-changes (hash-table-ref all-test-changes run-id)) - (new-test-dat (car test-changes)) - (removed-tests (cadr test-changes)) - (tests (sort (map cadr (filter (lambda (testrec) - (eq? run-id (db:mintest-get-run_id (cadr testrec)))) - new-test-dat)) - (lambda (a b) - (let ((time-a (db:mintest-get-event_time a)) - (time-b (db:mintest-get-event_time b))) - (> time-a time-b))))) - ;; test-changes is a list of (( id record ) ... ) - ;; Get list of test names sorted by time, remove tests - (test-names (delete-duplicates (map (lambda (t) - (let ((i (db:mintest-get-item_path t)) - (n (db:mintest-get-testname t))) - (if (string=? i "") - (conc " " i) - n))) - tests))) - (colnum (car (hash-table-ref runid-to-col run-id)))) - ;; for each test name get the slot if it exists and fill in the cell - ;; or take the next slot and fill in the cell, deal with items in the - ;; run view panel? The run view panel can have a tree selector for - ;; browsing the tests/items - - ;; SWITCH THIS TO USING CHANGED TESTS ONLY - (for-each (lambda (test) - (let* ((test-id (db:mintest-get-id test)) - (state (db:mintest-get-state test)) - (status (db:mintest-get-status test)) - (testname (db:mintest-get-testname test)) - (itempath (db:mintest-get-item_path test)) - (fullname (conc testname "/" itempath)) - (dispname (if (string=? itempath "") testname (conc " " itempath))) - (rownum (hash-table-ref/default testname-to-row fullname #f)) - (test-path (append run-path (if (equal? itempath "") - (list testname) - (list testname itempath)))) - (tb (dboard:tabdat-tests-tree data))) - (print "INFONOTE: run-path: " run-path) - (tree:add-node (dboard:tabdat-tests-tree data) "Runs" - test-path - userdata: (conc "test-id: " test-id)) - (let ((node-num (tree:find-node tb (cons "Runs" test-path))) - (color (car (gutils:get-color-for-state-status state status)))) - (debug:print 0 *default-log-port* "node-num: " node-num ", color: " color) - - (set! changed (dcommon:modifiy-if-different - tb - (conc "COLOR" node-num) - color changed)) - - ;; (iup:attribute-set! tb (conc "COLOR" node-num) color) - ) - (hash-table-set! (dboard:tabdat-path-test-ids data) test-path test-id) - (if (not rownum) - (let ((rownums (hash-table-values testname-to-row))) - (set! rownum (if (null? rownums) - 1 - (+ 1 (apply max rownums)))) - (hash-table-set! testname-to-row fullname rownum) - ;; create the label - (set! changed (dcommon:modifiy-if-different - (dboard:tabdat-runs-matrix data) - (conc rownum ":" 0) - dispname - changed)) - ;; (iup:attribute-set! (dboard:tabdat-runs-matrix data) - ;; (conc rownum ":" 0) dispname) - )) - ;; set the cell text and color - ;; (debug:print 2 *default-log-port* "rownum:colnum=" rownum ":" colnum ", state=" status) - (set! changed (dcommon:modifiy-if-different - (dboard:tabdat-runs-matrix data) - (conc rownum ":" colnum) - (if (member state '("ARCHIVED" "COMPLETED")) - status - state) - changed)) - ;; (iup:attribute-set! (dboard:tabdat-runs-matrix data) - ;; (conc rownum ":" colnum) - ;; (if (member state '("ARCHIVED" "COMPLETED")) - ;; status - ;; state)) - (set! changed (dcommon:modifiy-if-different - (dboard:tabdat-runs-matrix data) - (conc "BGCOLOR" rownum ":" colnum) - (car (gutils:get-color-for-state-status state status)) - changed)) - ;; (iup:attribute-set! (dboard:tabdat-runs-matrix data) - ;; (conc "BGCOLOR" rownum ":" colnum) - ;; (car (gutils:get-color-for-state-status state status))) - )) - tests))) - run-ids) - - (let ((updater (hash-table-ref/default (dboard:commondat-updaters commondat) window-id #f))) - (if updater (updater (hash-table-ref/default data get-details-sig #f)))) - - (if changed (iup:attribute-set! (dboard:tabdat-runs-matrix data) "REDRAW" "ALL")) - ;; (debug:print 2 *default-log-port* "run-changes: " run-changes) - ;; (debug:print 2 *default-log-port* "test-changes: " test-changes) - (list run-changes all-test-changes))) +;; (define (dcommon:run-update keys data runname keypatts testpatt states statuses mode window-id) +;; (let* (;; count and offset => #f so not used +;; ;; the synchash calls modify the "data" hash +;; (changed #f) +;; (get-runs-sig (conc (client:get-signature) " get-runs")) +;; (get-tests-sig (conc (client:get-signature) " get-tests")) +;; (get-details-sig (conc (client:get-signature) " get-test-details")) +;; +;; ;; test-ids to get and display are indexed on window-id in curr-test-ids hash +;; (test-ids (hash-table-values (dboard:tabdat-curr-test-ids data))) +;; ;; run-id is #f in next line to send the query to server 0 +;; (run-changes (synchash:client-get 'db:get-runs get-runs-sig (length keypatts) data #f runname #f #f keypatts)) +;; (tests-detail-changes (if (not (null? test-ids)) +;; (synchash:client-get 'db:get-test-info-by-ids get-details-sig 0 data #f test-ids) +;; '())) +;; +;; ;; Now can calculate the run-ids +;; (run-hash (hash-table-ref/default data get-runs-sig #f)) +;; (run-ids (if run-hash (filter number? (hash-table-keys run-hash)) '())) +;; +;; (all-test-changes (let ((res (make-hash-table))) +;; (for-each (lambda (run-id) +;; (if (> run-id 0) +;; (hash-table-set! res run-id (synchash:client-get 'db:get-tests-for-run-mindata get-tests-sig 0 data run-id 1 testpatt states statuses #f)))) +;; run-ids) +;; res)) +;; (runs-hash (hash-table-ref/default data get-runs-sig #f)) +;; (header (hash-table-ref/default runs-hash "header" #f)) +;; (run-ids (sort (filter number? (hash-table-keys runs-hash)) +;; (lambda (a b) +;; (let* ((record-a (hash-table-ref runs-hash a)) +;; (record-b (hash-table-ref runs-hash b)) +;; (time-a (db:get-value-by-header record-a header "event_time")) +;; (time-b (db:get-value-by-header record-b header "event_time"))) +;; (> time-a time-b))) +;; )) +;; (runid-to-col (hash-table-ref *cachedata* "runid-to-col")) +;; (testname-to-row (hash-table-ref *cachedata* "testname-to-row")) +;; (colnum 1) +;; (rownum 0) +;; (cellname (conc rownum ":" colnum))) ;; rownum = 0 is the header +;; ;; (debug:print 0 *default-log-port* "test-ids " test-ids ", tests-detail-changes " tests-detail-changes) +;; +;; ;; tests related stuff +;; ;; (all-testnames (delete-duplicates (map db:test-get-testname test-changes)))) +;; +;; ;; Given a run-id and testname/item_path calculate a cell R:C +;; +;; ;; NOTE: Also build the test tree browser and look up table +;; ;; +;; ;; Each run is unique on its keys and runname or run-id, store in hash on colnum +;; (for-each (lambda (run-id) +;; (let* ((run-record (hash-table-ref/default runs-hash run-id #f)) +;; (key-vals (map (lambda (key)(db:get-value-by-header run-record header key)) +;; keys)) +;; (run-name (db:get-value-by-header run-record header "runname")) +;; (col-name (conc (string-intersperse key-vals "\n") "\n" run-name)) +;; (run-path (append key-vals (list run-name)))) +;; (hash-table-set! (dboard:tabdat-run-keys data) run-id run-path) +;; ;; modify cell - but only if changed +;; (set! changed (dcommon:modifiy-if-different (dboard:tabdat-runs-matrix data) cellname col-name changed)) +;; (hash-table-set! runid-to-col run-id (list colnum run-record)) +;; ;; Here we update the tests treebox and tree keys +;; (tree:add-node (dboard:tabdat-tests-tree data) "Runs" (append key-vals (list run-name)) +;; userdata: (conc "run-id: " run-id)) +;; (set! colnum (+ colnum 1)))) +;; run-ids) +;; +;; ;; Scan all tests to be displayed and organise all the test names, respecting what is in the hash table +;; ;; Do this analysis in the order of the run-ids, the most recent run wins +;; (for-each (lambda (run-id) +;; (let* ((run-path (hash-table-ref (dboard:tabdat-run-keys data) run-id)) +;; (test-changes (hash-table-ref all-test-changes run-id)) +;; (new-test-dat (car test-changes)) +;; (removed-tests (cadr test-changes)) +;; (tests (sort (map cadr (filter (lambda (testrec) +;; (eq? run-id (db:mintest-get-run_id (cadr testrec)))) +;; new-test-dat)) +;; (lambda (a b) +;; (let ((time-a (db:mintest-get-event_time a)) +;; (time-b (db:mintest-get-event_time b))) +;; (> time-a time-b))))) +;; ;; test-changes is a list of (( id record ) ... ) +;; ;; Get list of test names sorted by time, remove tests +;; (test-names (delete-duplicates (map (lambda (t) +;; (let ((i (db:mintest-get-item_path t)) +;; (n (db:mintest-get-testname t))) +;; (if (string=? i "") +;; (conc " " i) +;; n))) +;; tests))) +;; (colnum (car (hash-table-ref runid-to-col run-id)))) +;; ;; for each test name get the slot if it exists and fill in the cell +;; ;; or take the next slot and fill in the cell, deal with items in the +;; ;; run view panel? The run view panel can have a tree selector for +;; ;; browsing the tests/items +;; +;; ;; SWITCH THIS TO USING CHANGED TESTS ONLY +;; (for-each (lambda (test) +;; (let* ((test-id (db:mintest-get-id test)) +;; (state (db:mintest-get-state test)) +;; (status (db:mintest-get-status test)) +;; (testname (db:mintest-get-testname test)) +;; (itempath (db:mintest-get-item_path test)) +;; (fullname (conc testname "/" itempath)) +;; (dispname (if (string=? itempath "") testname (conc " " itempath))) +;; (rownum (hash-table-ref/default testname-to-row fullname #f)) +;; (test-path (append run-path (if (equal? itempath "") +;; (list testname) +;; (list testname itempath)))) +;; (tb (dboard:tabdat-tests-tree data))) +;; (print "INFONOTE: run-path: " run-path) +;; (tree:add-node (dboard:tabdat-tests-tree data) "Runs" +;; test-path +;; userdata: (conc "test-id: " test-id)) +;; (let ((node-num (tree:find-node tb (cons "Runs" test-path))) +;; (color (car (gutils:get-color-for-state-status state status)))) +;; (debug:print 0 *default-log-port* "node-num: " node-num ", color: " color) +;; +;; (set! changed (dcommon:modifiy-if-different +;; tb +;; (conc "COLOR" node-num) +;; color changed)) +;; +;; ;; (iup:attribute-set! tb (conc "COLOR" node-num) color) +;; ) +;; (hash-table-set! (dboard:tabdat-path-test-ids data) test-path test-id) +;; (if (not rownum) +;; (let ((rownums (hash-table-values testname-to-row))) +;; (set! rownum (if (null? rownums) +;; 1 +;; (+ 1 (common:max rownums)))) +;; (hash-table-set! testname-to-row fullname rownum) +;; ;; create the label +;; (set! changed (dcommon:modifiy-if-different +;; (dboard:tabdat-runs-matrix data) +;; (conc rownum ":" 0) +;; dispname +;; changed)) +;; ;; (iup:attribute-set! (dboard:tabdat-runs-matrix data) +;; ;; (conc rownum ":" 0) dispname) +;; )) +;; ;; set the cell text and color +;; ;; (debug:print 2 *default-log-port* "rownum:colnum=" rownum ":" colnum ", state=" status) +;; (set! changed (dcommon:modifiy-if-different +;; (dboard:tabdat-runs-matrix data) +;; (conc rownum ":" colnum) +;; (if (member state '("ARCHIVED" "COMPLETED")) +;; status +;; state) +;; changed)) +;; ;; (iup:attribute-set! (dboard:tabdat-runs-matrix data) +;; ;; (conc rownum ":" colnum) +;; ;; (if (member state '("ARCHIVED" "COMPLETED")) +;; ;; status +;; ;; state)) +;; (set! changed (dcommon:modifiy-if-different +;; (dboard:tabdat-runs-matrix data) +;; (conc "BGCOLOR" rownum ":" colnum) +;; (car (gutils:get-color-for-state-status state status)) +;; changed)) +;; ;; (iup:attribute-set! (dboard:tabdat-runs-matrix data) +;; ;; (conc "BGCOLOR" rownum ":" colnum) +;; ;; (car (gutils:get-color-for-state-status state status))) +;; )) +;; tests))) +;; run-ids) +;; +;; (let ((updater (hash-table-ref/default (dboard:commondat-updaters commondat) window-id #f))) +;; (if updater (updater (hash-table-ref/default data get-details-sig #f)))) +;; +;; (if changed (iup:attribute-set! (dboard:tabdat-runs-matrix data) "REDRAW" "ALL")) +;; ;; (debug:print 2 *default-log-port* "run-changes: " run-changes) +;; ;; (debug:print 2 *default-log-port* "test-changes: " test-changes) +;; (list run-changes all-test-changes))) + +#;(define (dcommon:runsdat-get-col-num dat target runname force-set) + (let* ((runs-index (dboard:runsdat-runs-index dat)) + (col-name (conc target "/" runname)) + (res (hash-table-ref/default runs-index col-name #f))) + (if res + res + (if force-set + (let ((max-col-num (+ 1 (common:max (cons-1 (hash-table-values runs-index)))))) + (hash-table-set! runs-index col-name max-col-num) + max-col-num))))) + +#;(define (dcommon:runsdat-get-row-num dat testname itempath force-set) + (let* ((tests-index (dboard:runsdat-runs-index dat)) + (row-name (conc testname "/" itempath)) + (res (hash-table-ref/default runs-index row-name #f))) + (if res + res + (if force-set + (let ((max-row-num (+ 1 (common:max (cons -1 (hash-table-values tests-index)))))) + (hash-table-set! runs-index row-name max-row-num) + max-row-num))))) + +(define (dcommon:rundat-copy-tests-to-by-name rundat) + (let ((src-ht (dboard:rundat-tests rundat)) + (trg-ht (dboard:rundat-tests-by-name rundat))) + (if (and (hash-table? src-ht)(hash-table? trg-ht)) + (begin + (hash-table-clear! trg-ht) + (for-each + (lambda (testdat) + (hash-table-set! trg-ht (test:test-get-fullname testdat) testdat)) + (hash-table-values src-ht))) + (debug:print 0 *default-log-port* "WARNING: src-ht " src-ht " trg-ht " trg-ht)))) + ;;====================================================================== ;; TESTS DATA ;;====================================================================== @@ -277,31 +387,143 @@ (let* ((test-id (db:test-get-id hed)) ;; look at the tests-dat spec for locations (test-name (db:test-get-testname hed)) (item-path (db:test-get-item-path hed)) (state (db:test-get-state hed)) (status (db:test-get-status hed)) - (newitem (list test-name item-path (list test-id state status)))) + (event-time (db:test-get-event_time hed)) + (newitem (list test-name item-path (list test-id state status event-time)))) (if (null? tal) (reverse (cons newitem res)) (loop (car tal)(cdr tal)(cons newitem res))))))) + +(define (dcommon:tests-mindat->hash tests-mindat) + (let* ((res (make-hash-table))) + (for-each + (lambda (item) + (let* ((test-name+item-path (cons (list-ref item 0) (list-ref item 1))) + (value (list-ref item 2))) + (hash-table-set! res test-name+item-path value))) + tests-mindat) + res)) + +;; return 1 if status1 is better +;; return 0 if status1 and 2 are equally good +;; return -1 if status2 is better +(define (dcommon:status-compare3 status1 status2) + (let* + ((status-goodness-ranking (cdr ;; cdr to drop first item -- "n/a" + (append (map cadr *common:std-statuses*) + '(#f)) ;; algorithm requres last item to be #f + ) ) + (mem1 (member status1 status-goodness-ranking)) + (mem2 (member status2 status-goodness-ranking)) + ) + (cond + ((and (not mem1) (not mem2)) 0) + ((not mem1) -1) + ((not mem2) 1) + ((= (length mem1) (length mem2)) 0) + ((> (length mem1) (length mem2)) 1) + (else -1)))) + +(define (dcommon:xor-tests-mindat src-tests-mindat dest-tests-mindat #!key (hide-clean #f)) + (let* ((src-hash (dcommon:tests-mindat->hash src-tests-mindat)) + (dest-hash (dcommon:tests-mindat->hash dest-tests-mindat)) + (all-keys + (reverse (sort + (delete-duplicates + (append (hash-table-keys src-hash) (hash-table-keys dest-hash))) + + (lambda (a b) + (cond + ((< 0 (string-compare3 (car a) (car b))) #t) + ((> 0 (string-compare3 (car a) (car b))) #f) + ((< 0 (string-compare3 (cdr a) (cdr b))) #t) + (else #f))) + + )))) + (let ((res + (map ;; TODO: rename xor to delta globally in dcommon and dashboard + (lambda (key) + (let* ((test-name (car key)) + (item-path (cdr key)) + + (dest-value (hash-table-ref/default dest-hash key #f)) ;; (list test-id state status) + (dest-test-id (if dest-value (list-ref dest-value 0) #f)) + (dest-state (if dest-value (list-ref dest-value 1) #f)) + (dest-status (if dest-value (list-ref dest-value 2) #f)) + + (src-value (hash-table-ref/default src-hash key #f)) ;; (list test-id state status) + (src-test-id (if src-value (list-ref src-value 0) #f)) + (src-state (if src-value (list-ref src-value 1) #f)) + (src-status (if src-value (list-ref src-value 2) #f)) + + (incomplete-statuses '("DELETED" "INCOMPLETE" "STUCK/DEAD" "N/A")) ;; if any of these statuses apply, treat test as incomplete + + (dest-complete + (and dest-value dest-state dest-status + (equal? dest-state "COMPLETED") + (not (member dest-status incomplete-statuses)))) + (src-complete + (and src-value src-state src-status + (equal? src-state "COMPLETED") + (not (member src-status incomplete-statuses)))) + (status-compare-result (dcommon:status-compare3 src-status dest-status)) + (xor-new-item + (cond + ;; complete, for this case means: state=compelte AND status not in ( deleted uncomplete stuck/dead n/a ) + ;; neither complete -> bad + + ;; src !complete, dest complete -> better + ((and (not dest-complete) (not src-complete)) + (list dest-test-id "BOTH-BAD" "BOTH-INCOMPLETE")) + ((not dest-complete) + (list src-test-id "DIFF-MISSING" "DEST-INCOMPLETE")) + ((not src-complete) + (list dest-test-id "DIFF-NEW" "SRC-INCOMPLETE")) + ((and + (equal? src-state dest-state) + (equal? src-status dest-status)) + (list dest-test-id (conc "CLEAN") (conc "CLEAN-" dest-status) )) + ;; better or worse: pass > warn > waived > skip > fail > abort + ;; pass > warn > waived > skip > fail > abort + + ((= 1 status-compare-result) ;; src is better, dest is worse + (list dest-test-id "DIRTY-WORSE" (conc src-status "->" dest-status))) + (else + (list dest-test-id "DIRTY-BETTER" (conc src-status "->" dest-status))) + ))) + (list test-name item-path xor-new-item))) + all-keys))) + + (if hide-clean + (filter + (lambda (item) + ;;(print item) + (not + (equal? + "CLEAN" + (list-ref (list-ref item 2) 1)))) + res) + res)))) (define (dcommon:examine-xterm run-id test-id) (let* ((testdat (rmt:get-test-info-by-id run-id test-id))) (if (not testdat) - (begin - (debug:print 2 "ERROR: No test data found for test " test-id ", exiting") - (exit 1)) + (begin + (debug:print 2 "ERROR: No test data found for test " test-id ", exiting") + (exit 1)) (let* ((rundir (if testdat - (db:test-get-rundir testdat) - logfile)) + (db:test-get-rundir testdat) + (current-directory))) ;; logfile)) (testfullname (if testdat (db:test-get-fullname testdat) "Gathering data ...")) (xterm (lambda () (if (directory-exists? rundir) (let* ((shell (if (get-environment-variable "SHELL") - (conc "-e " (get-environment-variable "SHELL")) - "")) + (conc "-e " (get-environment-variable "SHELL")) + "")) (command (conc "cd " rundir ";mt_xterm -T \"" (string-translate testfullname "()" " ") "\" " shell "&"))) (print "Command =" command) (common:without-vars command @@ -315,21 +537,21 @@ ;;====================================================================== ;; Table of keys (define (dcommon:keys-matrix rawconfig) (let* ((curr-row-num 1) - (key-vals (configf:section-vars rawconfig "fields")) - (keys-matrix (iup:matrix - #:alignment1 "ALEFT" - #:expand "YES" ;; "HORIZONTAL" ;; "VERTICAL" - ;; #:scrollbar "YES" - #:numcol 1 - #:numlin (length key-vals) - #:numcol-visible 1 - #:numlin-visible (length key-vals) - #:click-cb (lambda (obj lin col status) - (print "obj: " obj " lin: " lin " col: " col " status: " status))))) + (key-vals (configf:section-vars rawconfig "fields")) + (keys-matrix (iup:matrix + #:alignment1 "ALEFT" + #:expand "YES" ;; "HORIZONTAL" ;; "VERTICAL" + ;; #:scrollbar "YES" + #:numcol 1 + #:numlin (length key-vals) + #:numcol-visible 1 + #:numlin-visible (length key-vals) + #:click-cb (lambda (obj lin col status) + (print "obj: " obj " lin: " lin " col: " col " status: " status))))) ;; (iup:attribute-set! keys-matrix "0:0" "Run Keys") (iup:attribute-set! keys-matrix "WIDTH0" 0) (iup:attribute-set! keys-matrix "0:1" "Key Name") ;; (iup:attribute-set! keys-matrix "WIDTH1" "100") ;; fill in keys @@ -344,18 +566,18 @@ keys-matrix)) ;; Section to table (define (dcommon:section-matrix rawconfig sectionname varcolname valcolname #!key (title #f)) (let* ((curr-row-num 1) - (key-vals (configf:section-vars rawconfig sectionname)) - (section-matrix (iup:matrix - #:alignment1 "ALEFT" - #:expand "YES" ;; "HORIZONTAL" - #:numcol 1 - #:numlin (length key-vals) - #:numcol-visible 1 - #:numlin-visible (min 10 (length key-vals)) + (key-vals (configf:section-vars rawconfig sectionname)) + (section-matrix (iup:matrix + #:alignment1 "ALEFT" + ;; #:expand "YES" ;; "HORIZONTAL" + #:numcol 1 + #:numlin (length key-vals) + #:numcol-visible 1 + #:numlin-visible (min 10 (length key-vals)) #:scrollbar "YES"))) (iup:attribute-set! section-matrix "0:0" varcolname) (iup:attribute-set! section-matrix "0:1" valcolname) (iup:attribute-set! section-matrix "WIDTH1" "200") ;; fill in keys @@ -394,90 +616,96 @@ ;; Megatest version (iup:attribute-set! general-matrix "2:0" "Version") (iup:attribute-set! general-matrix "2:1" (conc megatest-version "-" (substring megatest-fossil-hash 0 4))) general-matrix)) + +(define (dcommon:stats-updater commondat tabdat stats-matrix) + (if (and (iup:ihandle? stats-matrix) + (dashboard:database-changed? commondat tabdat context-key: 'run-stats)) + (let* ((changed #f) + (run-stats (rmt:get-run-stats)) + (indices (common:sparse-list-generate-index run-stats)) ;; proc: set-cell)) + (row-indices (car indices)) + (col-indices (cadr indices)) + (max-row (if (null? row-indices) 1 (common:max (map cadr row-indices)))) + (max-col (if (null? col-indices) 1 + (common:max (map cadr col-indices)))) + (max-visible (max (- (dboard:tabdat-num-tests tabdat) 15) 3)) + (max-col-vis (if (> max-col 10) 10 max-col)) + (numrows 1) + (numcols 1)) + (iup:attribute-set! stats-matrix "CLEARVALUE" "CONTENTS") + (iup:attribute-set! stats-matrix "NUMCOL" max-col ) + (iup:attribute-set! stats-matrix "NUMLIN" (if (< max-row max-visible) max-visible max-row)) ;; min of 20 + (iup:attribute-set! stats-matrix "NUMCOL_VISIBLE" max-col-vis) + (iup:attribute-set! stats-matrix "NUMLIN_VISIBLE" (if (> max-row max-visible) max-visible max-row)) + ;;(print "row-indices: " row-indices " col-indices: " col-indices) + ;; Row labels + (for-each (lambda (ind) + (let* ((name (car ind)) + (num (cadr ind)) + (key (conc num ":0"))) + (if (not (equal? (iup:attribute stats-matrix key) name)) + (begin + (set! changed #t) + (iup:attribute-set! stats-matrix key name))))) + row-indices) + + ;; Col labels + (for-each (lambda (ind) + (let* ((name (car ind)) + (num (cadr ind)) + (key (conc "0:" num))) + (if (not (equal? (iup:attribute stats-matrix key) name)) + (begin + (set! changed #t) + (iup:attribute-set! stats-matrix key name))))) + col-indices) + + ;; Cell contents + (for-each (lambda (entry) + (let* ((row-name (car entry)) + (col-name (cadr entry)) + (value (caddr entry)) + (row-num (cadr (assoc row-name row-indices))) + (col-num (cadr (assoc col-name col-indices))) + (key (conc row-num ":" col-num))) + (if (not (equal? (iup:attribute stats-matrix key) value)) + (begin + (set! changed #t) + (iup:attribute-set! stats-matrix key value))))) + run-stats) + (if changed (iup:attribute-set! stats-matrix "REDRAW" "ALL"))))) + (define (dcommon:run-stats commondat tabdat #!key (tab-num #f)) (let* ((stats-matrix (iup:matrix expand: "YES")) - (changed #f) (stats-updater (lambda () - (if (dashboard:database-changed? commondat tabdat) - (let* ((run-stats (rmt:get-run-stats)) - (indices (common:sparse-list-generate-index run-stats)) ;; proc: set-cell)) - (row-indices (car indices)) - (col-indices (cadr indices)) - (max-row (if (null? row-indices) 1 (apply max (map cadr row-indices)))) - (max-col (if (null? col-indices) 1 - (apply max (map cadr col-indices)))) - (max-visible (max (- (dboard:tabdat-num-tests tabdat) 15) 3)) - (max-col-vis (if (> max-col 10) 10 max-col)) - (numrows 1) - (numcols 1)) - (iup:attribute-set! stats-matrix "CLEARVALUE" "CONTENTS") - (iup:attribute-set! stats-matrix "NUMCOL" max-col ) - (iup:attribute-set! stats-matrix "NUMLIN" (if (< max-row max-visible) max-visible max-row)) ;; min of 20 - (iup:attribute-set! stats-matrix "NUMCOL_VISIBLE" max-col-vis) - (iup:attribute-set! stats-matrix "NUMLIN_VISIBLE" (if (> max-row max-visible) max-visible max-row)) - - ;; Row labels - (for-each (lambda (ind) - (let* ((name (car ind)) - (num (cadr ind)) - (key (conc num ":0"))) - (if (not (equal? (iup:attribute stats-matrix key) name)) - (begin - (set! changed #t) - (iup:attribute-set! stats-matrix key name))))) - row-indices) - - ;; Col labels - (for-each (lambda (ind) - (let* ((name (car ind)) - (num (cadr ind)) - (key (conc "0:" num))) - (if (not (equal? (iup:attribute stats-matrix key) name)) - (begin - (set! changed #t) - (iup:attribute-set! stats-matrix key name))))) - col-indices) - - ;; Cell contents - (for-each (lambda (entry) - (let* ((row-name (car entry)) - (col-name (cadr entry)) - (value (caddr entry)) - (row-num (cadr (assoc row-name row-indices))) - (col-num (cadr (assoc col-name col-indices))) - (key (conc row-num ":" col-num))) - (if (not (equal? (iup:attribute stats-matrix key) value)) - (begin - (set! changed #t) - (iup:attribute-set! stats-matrix key value))))) - run-stats) - (if changed (iup:attribute-set! stats-matrix "REDRAW" "ALL"))))))) - (stats-updater) + (dcommon:stats-updater commondat tabdat stats-matrix)))) + ;; (dboard:commondat-please-update-set! commondat #t) ;; force redraw on first pass + ;; (mark-for-update tabdat) + ;; (stats-updater) (dboard:commondat-add-updater commondat stats-updater tab-num: tab-num) ;; (set! dashboard:update-summary-tab updater) (iup:attribute-set! stats-matrix "WIDTHDEF" "40") (iup:vbox ;; (iup:label "Run statistics" #:expand "HORIZONTAL") stats-matrix))) (define (dcommon:servers-table commondat tabdat) - (let* ((tdbdat (tasks:open-db)) - (colnum 0) + (let* ((colnum 0) (rownum 0) (servers-matrix (iup:matrix #:expand "YES" #:numcol 7 #:numcol-visible 7 #:numlin-visible 5 )) (colnames (list "Id" "MTver" "Pid" "Host" "Interface:OutPort" "RunTime" "State" "RunId")) (updater (lambda () (if (dashboard:monitor-changed? commondat tabdat) - (let ((servers (tasks:get-all-servers (db:delay-if-busy tdbdat)))) + (let ((servers (server:get-list *toppath* limit: 10))) (iup:attribute-set! servers-matrix "NUMLIN" (length servers)) ;; (set! colnum 0) ;; (for-each (lambda (colname) ;; ;; (print "colnum: " colnum " colname: " colname) ;; (iup:attribute-set! servers-matrix (conc "0:" colnum) colname) @@ -485,36 +713,40 @@ ;; colnames) (set! rownum 1) (for-each (lambda (server) (set! colnum 0) - (let* ((vals (list (vector-ref server 0) ;; Id - (vector-ref server 9) ;; MT-Ver - (vector-ref server 1) ;; Pid - (vector-ref server 2) ;; Hostname - (conc (vector-ref server 3) ":" (vector-ref server 4)) ;; IP:Port - (seconds->hr-min-sec (- (current-seconds)(vector-ref server 6))) - ;; (vector-ref server 5) ;; Pubport - ;; (vector-ref server 10) ;; Last beat - ;; (vector-ref server 6) ;; Start time - ;; (vector-ref server 7) ;; Priority - ;; (vector-ref server 8) ;; State - (vector-ref server 8) ;; State - (vector-ref server 12) ;; RunId - ))) - (for-each (lambda (val) - (let* ((row-col (conc rownum ":" colnum)) - (curr-val (iup:attribute servers-matrix row-col))) - (if (not (equal? (conc val) curr-val)) - (begin - (iup:attribute-set! servers-matrix row-col val) - (iup:attribute-set! servers-matrix "FITTOTEXT" (conc "C" colnum)))) - (set! colnum (+ 1 colnum)))) - vals) - (set! rownum (+ rownum 1))) - (iup:attribute-set! servers-matrix "REDRAW" "ALL")) - servers)))))) + (match-let (((mod-time host port start-time pid) + server)) + (let* ((uptime (- (current-seconds) mod-time)) + (runtime (if start-time + (- mod-time start-time) + 0)) + (vals (list "-" ;; (vector-ref server 0) ;; Id + "-" ;; (vector-ref server 9) ;; MT-Ver + pid ;; (vector-ref server 1) ;; Pid + host ;; (vector-ref server 2) ;; Hostname + (conc host ":" port) ;; (conc (vector-ref server 3) ":" (vector-ref server 4)) ;; IP:Port + (seconds->hr-min-sec runtime) ;; (- (current-seconds) start-time)) ;; (vector-ref server 6))) + (cond + ((< uptime 5) "alive") + ((< uptime 16) "probably alive");; less than 15 seconds since mod, call it alive (vector-ref server 8) ;; State + (else "dead")) + "-" ;; (vector-ref server 12) ;; RunId + ))) + (for-each (lambda (val) + (let* ((row-col (conc rownum ":" colnum)) + (curr-val (iup:attribute servers-matrix row-col))) + (if (not (equal? (conc val) curr-val)) + (begin + (iup:attribute-set! servers-matrix row-col val) + (iup:attribute-set! servers-matrix "FITTOTEXT" (conc "C" colnum)))) + (set! colnum (+ 1 colnum)))) + vals) + (set! rownum (+ rownum 1))) + (iup:attribute-set! servers-matrix "REDRAW" "ALL"))) + (sort servers (lambda (a b)(> (car a)(car b)))))))))) (set! colnum 0) (for-each (lambda (colname) (iup:attribute-set! servers-matrix (conc "0:" colnum) colname) (iup:attribute-set! servers-matrix "FITTOTEXT" (conc "C" colnum)) (set! colnum (+ colnum 1))) @@ -559,11 +791,11 @@ (iup:menu-item "Files" (iup:menu ;; Note that you can use either #:action or action: for options (iup:menu-item "Open" action: (lambda (obj) (let* ((area-name (iup:textbox #:expand "HORIZONTAL")) (fd (iup:file-dialog #:dialogtype "DIR")) (top (iup:show fd #:modal? "YES"))) - (iup:attribute-set! source-tb "VALUE" + (iup:attribute-set! area-name "VALUE" ;; was source-tb, no idea what is correct (iup:attribute fd "VALUE")) (iup:destroy! fd)))) ;; (lambda (obj) ;; (iup:show (iup:file-dialog)) ;; (print "File->open " obj))) @@ -721,14 +953,13 @@ (+ yoffset (* y scalef))) ;; sizex, sizey - canvas size ;; originx, originy - canvas origin ;; -(define (dcommon:initial-draw-tests cnv xadj yadj sizex sizey sizexmm sizeymm originx originy tests-draw-state sorted-testnames test-records) - (let* ((dot-data ;; (map cdr (filter - ;; (lambda (x)(equal? "node" (car x))) - (map string-split (tests:lazy-dot test-records "plain" sizex sizey))) ;; (tests:easy-dot test-records "plain"))) +(define (dcommon:initial-draw-tests cnv xadj yadj sizex sizey sizexmm sizeymm originx originy + tests-draw-state sorted-testnames test-records) + (let* ((dot-data (tests:lazy-dot test-records "plain" sizex sizey 'munged)) (xoffset (dcommon:get-xoffset tests-draw-state sizex xadj)) (yoffset (dcommon:get-yoffset tests-draw-state sizey yadj)) (no-dot (configf:lookup *configdat* "setup" "nodot")) (boxh 15) (boxw 10) @@ -783,24 +1014,28 @@ (lambda (x y) (list (+ x 0) ;; xtorig) (+ y 0))) ;; ytorig))) #f #f)) ;; process polyline edges)))) - (llx (if no-dot + (cx (if no-dot ;; this is the centerpoint! curr-x (string->number (list-ref nodedat 2)))) - (lly (if no-dot + (cy (if no-dot curr-y (string->number (list-ref nodedat 3)))) (boxw (if no-dot boxw (string->number (list-ref nodedat 4)))) (boxh (if no-dot boxh (string->number (list-ref nodedat 5)))) - (urx (+ llx boxw)) - (ury (+ lly boxh))) + (boxw/2 (/ boxw 2)) + (boxh/2 (/ boxh 2)) + (urx (+ cx boxw/2)) + (ury (+ cy boxh/2)) + (llx (- cx boxw/2)) + (lly (- cy boxh/2))) ;; if we are in no-dot mode then increment curr-x and curr-y as needed (if no-dot (begin (cond @@ -891,21 +1126,21 @@ ))) (dboard:tabdat-command-tb-set! data tb) tb) (iup:button "Execute" #:size "50x" #:action (lambda (obj) - (let ((cmd (conc "xterm -geometry 180x20 -e \"" - (iup:attribute (dboard:tabdat-command-tb data) "VALUE") - ";echo Press any key to continue;bash -c 'read -n 1 -s'\" &"))) - (system cmd))))))) + ;; (let ((cmd (conc ;; "xterm -geometry 180x20 -e \"" + (common:run-a-command (iup:attribute (dboard:tabdat-command-tb data) "VALUE"))))))) + ;; ";echo Press any key to continue;bash -c 'read -n 1 -s'\" &"))) + ;; (system cmd))))))) (define (dcommon:command-action-selector commondat tabdat #!key (tab-num #f)) (iup:frame #:title "Set the action to take" (iup:hbox ;; (iup:label "Command to run" #:expand "HORIZONTAL" #:size "70x" #:alignment "LEFT:ACENTER") - (let* ((cmds-list '("run" "remove-runs" "set-state-status" "lock-runs" "unlock-runs")) + (let* ((cmds-list '("run" "remove-runs")) ;; "set-state-status" "lock-runs" "unlock-runs")) (lb (iup:listbox #:expand "HORIZONTAL" #:dropdown "YES" #:action (lambda (obj val index lbstate) ;; (print obj " " val " " index " " lbstate) (dboard:tabdat-command-set! tabdat val) @@ -925,11 +1160,11 @@ (lambda () ;; (print "obj: " obj " val: " val " unk: " unk) (dboard:tabdat-run-name-set! tabdat txt) ;; (iup:attribute obj "VALUE")) (dashboard:update-run-command tabdat)) "command-runname-selector tb action")) - #:value (or default-run-name (dboard:tabdat-run-name tabdat)))) + #:value (or (args:get-arg "-runname") default-run-name (dboard:tabdat-run-name tabdat)))) (lb (iup:listbox #:expand "HORIZONTAL" #:dropdown "YES" #:action (lambda (obj val index lbstate) (debug:catch-and-dump (lambda () @@ -938,24 +1173,25 @@ (iup:attribute-set! tb "VALUE" val) (dboard:tabdat-run-name-set! tabdat val) (dashboard:update-run-command tabdat)))) "command-runname-selector lb action")))) (refresh-runs-list (lambda () - (if (dashboard:database-changed? commondat tabdat) - (let* ((target (dboard:tabdat-target-string tabdat)) - (runs-for-targ (rmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" target #f #f #f 0)) + (if (dashboard:database-changed? commondat tabdat context-key: 'runname-selector-runs-list) + (let* (;; (target (dboard:tabdat-target-string tabdat)) + (runs-for-targ (rmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f 0)) (runs-header (vector-ref runs-for-targ 0)) (runs-dat (vector-ref runs-for-targ 1)) (run-names (cons default-run-name (map (lambda (x) (db:get-value-by-header x runs-header "runname")) runs-dat)))) + ;; (print "DEBUGINFO: run-names=" run-names) ;; (iup:attribute-set! lb "REMOVEITEM" "ALL") (iuplistbox-fill-list lb run-names selected-item: default-run-name)))))) ;; (dboard:tabdat-updater-for-runs-set! tabdat refresh-runs-list) (dboard:commondat-add-updater commondat refresh-runs-list tab-num: tab-num) - (refresh-runs-list) + ;; (refresh-runs-list) (dboard:tabdat-run-name-set! tabdat default-run-name) (iup:hbox tb lb)))) @@ -973,42 +1209,44 @@ (dashboard:update-run-command tabdat)) "command-testname-selector tb action")) #:value (dboard:test-patt->lines (dboard:tabdat-test-patts-use tabdat)) #:expand "YES" - #:size "10x30" + #:size "x30" ;; was 10x30 #:multiline "YES"))) (set! test-patterns-textbox tb) + (dboard:tabdat-test-patterns-textbox-set! tabdat tb) tb)) ;; (iup:frame ;; #:title "Target" ;; ;; Target selectors ;; (apply iup:hbox ;; (let* ((dat (dashboard:update-target-selector tabdat action-proc: update-keyvals)) ;; (key-lb (car dat)) ;; (combos (cadr dat))) ;; combos))) - (iup:hbox - ;; Text box for STATES - (iup:frame - #:title "States" - (dashboard:text-list-toggle-box - ;; Move these definitions to common and find the other useages and replace! - (map cadr *common:std-states*) ;; '("COMPLETED" "RUNNING" "STUCK" "INCOMPLETE" "LAUNCHED" "REMOTEHOSTSTART" "KILLED") - (lambda (all) - (dboard:tabdat-states-set! tabdat all) - (dashboard:update-run-command tabdat)))) - ;; Text box for STATES - (iup:frame - #:title "Statuses" - (dashboard:text-list-toggle-box - (map cadr *common:std-statuses*) ;; '("PASS" "FAIL" "n/a" "CHECK" "WAIVED" "SKIP" "DELETED" "STUCK/DEAD") - (lambda (all) - (dboard:tabdat-statuses-set! tabdat all) - (dashboard:update-run-command tabdat))))))) - -(define (dcommon:command-tests-tasks-canvas data test-records sorted-testnames tests-draw-state) + ;; (iup:hbox + ;; ;; Text box for STATES + ;; (iup:frame + ;; #:title "States" + ;; (dashboard:text-list-toggle-box + ;; ;; Move these definitions to common and find the other useages and replace! + ;; (map cadr *common:std-states*) ;; '("COMPLETED" "RUNNING" "STUCK" "INCOMPLETE" "LAUNCHED" "REMOTEHOSTSTART" "KILLED") + ;; (lambda (all) + ;; (dboard:tabdat-states-set! tabdat all) + ;; (dashboard:update-run-command tabdat)))) + ;; ;; Text box for STATES + ;; (iup:frame + ;; #:title "Statuses" + ;; (dashboard:text-list-toggle-box + ;; (map cadr *common:std-statuses*) ;; '("PASS" "FAIL" "n/a" "CHECK" "WAIVED" "SKIP" "DELETED" "STUCK/DEAD") + ;; (lambda (all) + ;; (dboard:tabdat-statuses-set! tabdat all) + ;; (dashboard:update-run-command tabdat))))) + )) + +(define (dcommon:command-tests-tasks-canvas tabdat test-records sorted-testnames tests-draw-state) (iup:frame #:title "Tests and Tasks" (let* ((updater #f) (last-xadj 0) (last-yadj 0) @@ -1033,11 +1271,11 @@ (* scalef 0.01) (* scalef -0.01)))) (if the-cnv (dashboard:draw-tests the-cnv last-xadj last-yadj tests-draw-state sorted-testnames test-records)) )) - ;; #:size "50x50" + ;; #:size "250x250" #:expand "YES" #:scrollbar "YES" #:posx "0.5" #:posy "0.5" #:button-cb (lambda (obj btn pressed x y status) @@ -1050,11 +1288,12 @@ (selected-tests (hash-table-ref tests-draw-state 'selected-tests)) (scalef (hash-table-ref tests-draw-state 'scalef)) (sizey (hash-table-ref tests-draw-state 'sizey)) (xoffset (dcommon:get-xoffset tests-draw-state #f #f)) (yoffset (dcommon:get-yoffset tests-draw-state #f #f)) - (new-y (- sizey y))) + (new-y (- sizey y)) + (test-patterns-textbox (dboard:tabdat-test-patterns-textbox tabdat))) ;; (print "xoffset=" xoffset ", yoffset=" yoffset) ;; (print "\tx\ty\tllx\tlly\turx\tury") (for-each (lambda (test-name) (let* ((rec-coords (hash-table-ref tests-info test-name)) (llx (dcommon:x->canvas (list-ref rec-coords 0) scalef xoffset)) @@ -1066,46 +1305,72 @@ (if (and (eq? pressed 1) (>= x llx) (>= new-y lly) (<= x urx) (<= new-y ury)) - (let ((patterns (string-split (iup:attribute test-patterns-textbox "VALUE")))) + (let* ((box-patterns (string-split (iup:attribute test-patterns-textbox "VALUE"))) + (test-patts (string-split (or (dboard:tabdat-test-patts tabdat) + "") + ",")) + (patterns (delete-duplicates (append box-patterns test-patts)))) (let* ((selected (not (member test-name patterns))) (newpatt-list (if selected (cons test-name patterns) (delete test-name patterns))) (newpatt (string-intersperse newpatt-list "\n"))) + (iup:attribute-set! test-patterns-textbox "VALUE" newpatt) (iup:attribute-set! obj "REDRAW" "ALL") (hash-table-set! selected-tests test-name selected) - (iup:attribute-set! test-patterns-textbox "VALUE" newpatt) - (dboard:tabdat-test-patts-set!-use data (dboard:lines->test-patt newpatt)) - (dashboard:update-run-command data) + (dboard:tabdat-test-patts-set!-use tabdat (dboard:lines->test-patt newpatt)) + (dashboard:update-run-command tabdat) (if updater (updater last-xadj last-yadj))))))) (hash-table-keys tests-info))))))) canvas-obj))) ;;====================================================================== ;; S T E P S ;;====================================================================== -(define (dcommon:populate-steps teststeps steps-matrix) - (let ((max-row 0) - (max-col 7)) +(define (dcommon:populate-steps teststeps steps-matrix run-id test-id) + (let* ((max-row 0) + (max-col 9) + (white "255 255 255") + + (testinfo (rmt:get-testinfo-state-status run-id test-id)) + (state (db:test-get-state testinfo)) + (status (db:test-get-status testinfo)) + (test-status-color (car (gutils:get-color-for-state-status state status))) + (running-color (car (gutils:get-color-for-state-status "RUNNING" "STARTED"))) + (failcolor (car (gutils:get-color-for-state-status "COMPLETED" "FAIL")))) (if (null? teststeps) - (iup:attribute-set! steps-matrix "CLEARVALUE" "CONTENTS") + (begin + (iup:attribute-set! steps-matrix "CLEARATTRIB" "CONTENTS") + (iup:attribute-set! steps-matrix "CLEARVALUE" "CONTENTS")) (let loop ((hed (car teststeps)) (tal (cdr teststeps)) (rownum 1) (colnum 1)) (if (> rownum max-row)(set! max-row rownum)) - (let ((val (vector-ref hed (- colnum 1))) - (mtrx-rc (conc rownum ":" colnum))) + (let* ((status (vector-ref hed 3)) + (val (vector-ref hed (- colnum 1))) + (bgcolor (cond + ((member (conc status) '("" "-" "#")) + running-color) + + ((member (conc status) '("0" 0)) + white) + (else test-status-color))) + ; (else failcolor))) + (mtrx-rc (conc rownum ":" colnum))) + ;;(print "BB> status=>"status"< bgcolor="bgcolor) (iup:attribute-set! steps-matrix mtrx-rc (if val (conc val) "")) + (if (< colnum 5) + (iup:attribute-set! steps-matrix (conc "BGCOLOR" mtrx-rc) bgcolor)) (if (< colnum max-col) (loop hed tal rownum (+ colnum 1)) (if (not (null? tal)) - (loop (car tal)(cdr tal)(+ rownum 1) 1)))))) + (loop (car tal) (cdr tal) (+ rownum 1) 1)))))) (if (> max-row 0) (begin ;; we are going to speculatively clear rows until we find a row that is already cleared (let loop ((rownum (+ max-row 1)) (colnum 0) @@ -1123,5 +1388,74 @@ (loop next-row next-col #t)) (if (eq? colnum max-col) ;; not done, didn't get a full blank row (if deleted (loop next-row next-col #f)) ;; exit on this not met (loop next-row next-col deleted))))) (iup:attribute-set! steps-matrix "REDRAW" "ALL"))))) + +;;====================================================================== +;; U T I L I T I E S +;;====================================================================== + +(define (dcommon:run-html-viewer lfilename) + (let ((htmlviewercmd (configf:lookup *configdat* "setup" "htmlviewercmd"))) + (if htmlviewercmd + (system (conc "(" htmlviewercmd " " lfilename " ) &")) + (iup:send-url lfilename)))) + +(define (dashboard:monitor-changed? commondat tabdat) + (let* ((run-update-time (current-seconds)) + (monitor-db-path (dboard:tabdat-monitor-db-path tabdat)) + (monitor-modtime (if (and monitor-db-path (common:file-exists? monitor-db-path)) + (file-modification-time monitor-db-path) + -1))) + (if (and (eq? (dboard:commondat-curr-tab-num commondat) 0) + (or (> monitor-modtime *last-monitor-update-time*) + (> (- run-update-time *last-monitor-update-time*) 5))) ;; update every 1/2 minute just in case + (begin + (set! *last-monitor-update-time* run-update-time) ;; monitor-modtime) + #t) + #f))) + +;; DOES NOT WORK RELIABLY WITH /tmp WAL mode files. Timestamps only change when the db +;; is closed (I think). If db dir starts with /tmp always return true +;; +(define (dashboard:database-changed? commondat tabdat #!key (context-key 'default)) + (let* ((run-update-time (current-seconds)) + (dbdir (dboard:tabdat-dbdir tabdat)) + (modtime (dashboard:get-youngest-run-db-mod-time dbdir)) + (recalc (dashboard:recalc modtime + (dboard:commondat-please-update commondat) + (dboard:get-last-db-update tabdat context-key)))) + ;; (dboard:tabdat-last-db-update tabdat)))) + (if recalc + (dboard:set-last-db-update! tabdat context-key run-update-time)) + (dboard:commondat-please-update-set! commondat #f) + recalc)) + +(define (dashboard:get-youngest-run-db-mod-time dbdir) + (handle-exceptions + exn + (begin + (debug:print 2 *default-log-port* "WARNING: error in accessing databases in get-youngest-run-db-mod-time: " ((condition-property-accessor 'exn 'message) exn) + " db-dir="dbdir ", exn=" exn) + (current-seconds)) ;; something went wrong - just print an error and return current-seconds + (common:max (map (lambda (filen) + (file-modification-time filen)) + (glob (conc dbdir "/*.db*")))))) + +(define (dboard:get-last-db-update tabdat context) + (hash-table-ref/default (dboard:tabdat-last-db-update tabdat) context 0)) + +(define (dboard:set-last-db-update! tabdat context newtime) + (hash-table-set! (dboard:tabdat-last-db-update tabdat) context newtime)) + +;; point inside line +;; +(define-inline (dashboard:px-between px lx1 lx2) + (and (< lx1 px)(> lx2 px))) + +(define (dashboard:recalc modtime please-update-buttons last-db-update-time) + (or please-update-buttons + (and ;; (> (current-milliseconds)(+ *last-recalc-ended-time* 150)) ;; can't use this - it needs to be tab specific + (> modtime (- last-db-update-time 3)) ;; add three seconds of margin + (> (current-seconds)(+ last-db-update-time 1))))) + DELETED debugger.scm Index: debugger.scm ================================================================== --- debugger.scm +++ /dev/null @@ -1,73 +0,0 @@ -(use iup) - -(define *debugger-control* #f) -(define *debugger-rownum* 0) -(define *debugger-matrix* #f) -(define *debugger* #f) - -(define (debugger) - (if (not *debugger*) - (set! *debugger* - (thread-start! - (make-thread - (lambda () - (show - (dialog - (let ((pause #f) - (mtrx (matrix - #:expand "YES" - #:numlin 30 - #:numcol 3 - #:numlin-visible 20 - #:numcol-visible 2 - #:alignment1 "ALEFT" - ))) - (set! pause (button "Pause" - #:action (lambda (obj) - (set! *debugger-control* (not *debugger-control*)) - (attribute-set! pause "BGCOLOR" (if *debugger-control* - "200 0 0" - "0 0 200"))))) - (set! *debugger-matrix* mtrx) - (attribute-set! mtrx "WIDTH1" "300") - (vbox - mtrx - (hbox - pause))))) - (main-loop))))))) - -(define (debugger-start #!key (start 2)) - (set! *debugger-rownum* start)) - -(define (debugger-trace-var varname varval) - (let ((oldval (attribute *debugger-matrix* (conc *debugger-rownum* ":1"))) - (newval (conc varval))) - (if (not (equal? oldval newval)) - (begin - ;; (print "DEBUG: " varname " = " newval) - (attribute-set! *debugger-matrix* (conc *debugger-rownum* ":0") varname) - (attribute-set! *debugger-matrix* (conc *debugger-rownum* ":1") (conc varval)) - ;; (attribute-set! *debugger-matrix* "FITTOTEXT" "C1") - )) - (set! *debugger-rownum* (+ *debugger-rownum* 1)))) - - -(define (debugger-pauser) - (debugger) - (attribute-set! *debugger-matrix* "REDRAW" "ALL") - (let loop () - (if *debugger-control* - (begin - (print "PAUSED!") - (thread-sleep! 1) - (loop)) - ;;(thread-sleep! 0.01) - ))) - -;; ;; lets use the debugger eh? -;; (debugger-start) -;; (debugger-trace-var "can-run-more" can-run-more) -;; (debugger-trace-var "hed" hed) -;; (debugger-trace-var "prereqs-not-met" (runs:pretty-string prereqs-not-met)) -;; (debugger-pauser) - ADDED diff-report.scm Index: diff-report.scm ================================================================== --- /dev/null +++ diff-report.scm @@ -0,0 +1,425 @@ +;; Copyright 2006-2017, Matthew Welland. +;; +;; This file is part of Megatest. +;; +;; Megatest is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. +;; +;; Megatest is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with Megatest. If not, see . +;; + +(declare (unit diff-report)) +(declare (uses common)) +(declare (uses rmt)) + +(include "common_records.scm") +(use matchable) +(use fmt) +(use ducttape-lib) +(define css "") + +(define (diff:tests-mindat->hash tests-mindat) + (let* ((res (make-hash-table))) + (for-each + (lambda (item) + (let* ((test-name+item-path (cons (list-ref item 0) (list-ref item 1))) + (value (list-ref item 2))) + (hash-table-set! res test-name+item-path value))) + tests-mindat) + res)) + +;; return 1 if status1 is better +;; return 0 if status1 and 2 are equally good +;; return -1 if status2 is better +(define (diff:status-compare3 status1 status2) + (let* + ((status-goodness-ranking (list "PASS" "WARN" "WAIVED" "SKIP" "FAIL" "ABORT" #f)) + (mem1 (member status1 status-goodness-ranking)) + (mem2 (member status2 status-goodness-ranking)) + ) + (cond + ((and (not mem1) (not mem2)) 0) + ((not mem1) -1) + ((not mem2) 1) + ((= (length mem1) (length mem2)) 0) + ((> (length mem1) (length mem2)) 1) + (else -1)))) + + +(define (diff:xor-tests-mindat src-tests-mindat dest-tests-mindat #!key (hide-clean #f) (consistent-fail-not-clean #f)) + (let* ((src-hash (diff:tests-mindat->hash src-tests-mindat)) + (dest-hash (diff:tests-mindat->hash dest-tests-mindat)) + (all-keys + (reverse (sort + (delete-duplicates + (append (hash-table-keys src-hash) (hash-table-keys dest-hash))) + + (lambda (a b) + (cond + ((< 0 (string-compare3 (car a) (car b))) #t) + ((> 0 (string-compare3 (car a) (car b))) #f) + ((< 0 (string-compare3 (cdr a) (cdr b))) #t) + (else #f))) + + )))) + (let ((res + (map ;; TODO: rename xor to delta globally in dcommon and dashboard + (lambda (key) + (let* ((test-name (car key)) + (item-path (cdr key)) + + (dest-value (hash-table-ref/default dest-hash key (list 0 "NULL" "NULL"))) ;; (list test-id state status) + (dest-test-id (list-ref dest-value 0)) + (dest-state (list-ref dest-value 1)) + (dest-status (list-ref dest-value 2)) + + (src-value (hash-table-ref/default src-hash key (list 0 "NULL" "NULL"))) ;; (list test-id state status) + (src-test-id (list-ref src-value 0)) + (src-state (list-ref src-value 1)) + (src-status (list-ref src-value 2)) + + (incomplete-statuses '("DELETED" "INCOMPLETE" "STUCK/DEAD" "N/A")) ;; if any of these statuses apply, treat test as incomplete + + (dest-complete + (and dest-value dest-state dest-status + (equal? dest-state "COMPLETED") + (not (member dest-status incomplete-statuses)))) + (src-complete + (and src-value src-state src-status + (equal? src-state "COMPLETED") + (not (member src-status incomplete-statuses)))) + (status-compare-result (diff:status-compare3 src-status dest-status)) + (xor-new-item + (cond + ;; complete, for this case means: state=compelte AND status not in ( deleted uncomplete stuck/dead n/a ) + ;; neither complete -> bad + + ;; src !complete, dest complete -> better + ((and (not dest-complete) (not src-complete)) + (list dest-test-id "BOTH-BAD" "BOTH-INCOMPLETE") src-value dest-value) + ((not dest-complete) + (list src-test-id "NOT-IN-DEST" "DEST-INCOMPLETE") src-value dest-value) + ((not src-complete) + (list dest-test-id "NOT-IN-SRC" "SRC-INCOMPLETE") src-value dest-value) + ((and + (equal? src-state dest-state) + (equal? src-status dest-status)) + (if (and consistent-fail-not-clean (not (member dest-status '("PASS" "SKIP" "WAIVED" "WARN")))) + (list dest-test-id (conc "BOTH-BAD") (conc "CLEAN-" dest-status) src-value dest-value) + (list dest-test-id (conc "CLEAN") (conc "CLEAN-" dest-status) src-value dest-value))) + ;; better or worse: pass > warn > waived > skip > fail > abort + ;; pass > warn > waived > skip > fail > abort + + ((= 1 status-compare-result) ;; src is better, dest is worse + (list dest-test-id "WORSE" (conc src-status "->" dest-status) src-value dest-value)) + (else + (list dest-test-id "BETTER" (conc src-status "->" dest-status) src-value dest-value))))) + (list test-name item-path xor-new-item))) + all-keys))) + + (if hide-clean + (filter + (lambda (item) + (not + (equal? + "CLEAN" + (list-ref (list-ref item 2) 1)))) + res) + res)))) + +(define (diff:run-name->run-id run-name) + (if (number? run-name) + run-name + (let* ((qry-res (rmt:get-runs run-name 1 0 '()))) + (if (eq? 2 (vector-length qry-res)) + (vector-ref (car (vector-ref qry-res 1)) 1) + #f)))) + +(define (diff:target+run-name->run-id target run-name) + (let* ((keys (rmt:get-keys)) + (target-parts (if target (string-split target "/") (map (lambda (x) "%") keys)))) + (if (not (eq? (length keys) (length keys))) + (begin + (print "Error: Target ("target") item count does not match fields count target tokens="target-parts" fields="keys) + #f) + (let* ((target-map (zip keys target-parts)) + (qry-res (rmt:get-runs run-name 1 0 target-map))) + + (if (eq? 2 (vector-length qry-res)) + (let ((first-ent (vector-ref qry-res 1))) + (if (> (length first-ent) 0) + (vector-ref (car first-ent) 1) + #f)) + #f))))) + +(define (diff:run-id->tests-mindat run-id #!key (testpatt "%/%")) + (let* ((states '()) + (statuses '()) + (offset #f) + (limit #f) + (not-in #t) + (sort-by #f) + (sort-order #f) + (qryvals "id,testname,item_path,state,status") + (qryvals "id,testname,item_path,state,status") + (last-update 0) + (mode #f) + ) + (map + ;; (lambda (row) + ;; (match row + ;; ((#(id test-name item-path state status) + ;; (list test-name item-path (list id state status)))) + ;; (else #f))) + (lambda (row) + (let* ((id (vector-ref row 0)) + (test-name (vector-ref row 1)) + (item-path (vector-ref row 2)) + (state (vector-ref row 3)) + (status (vector-ref row 4))) + (list test-name item-path (list id state status)))) + + (rmt:get-tests-for-run run-id + testpatt states statuses + offset limit + not-in sort-by sort-order + qryvals + last-update + mode)))) + + +(define (diff:diff-runs src-run-id dest-run-id) + (let* ((src-tests-mindat (diff:run-id->tests-mindat src-run-id)) + (dest-tests-mindat (diff:run-id->tests-mindat dest-run-id))) + (diff:xor-tests-mindat src-tests-mindat dest-tests-mindat consistent-fail-not-clean: #t))) + + +(define (diff:rundiff-find-by-state run-diff state) + (filter + (lambda (x) + (equal? (list-ref (caddr x) 1) state)) + run-diff)) + +(define (diff:rundiff-clean-breakdown run-diff) + (map + (lambda (run-diff-item) + (match run-diff-item + ((test-name item-path (junk-id diff-state diff-status (src-test-id src-state src-status) (dest-test-id dest-state dest-status))) + (list test-name item-path "CLEAN" src-status)) + (else ""))) + (diff:rundiff-find-by-state run-diff "CLEAN"))) + +(define (diff:summarize-run-diff run-diff) + + (let* ((diff-states (list "CLEAN" "BETTER" "WORSE" "BOTH-BAD" "NOT-IN-DEST" "NOT-IN-SRC" ))) + (map + (lambda (state) + (list state + (length (diff:rundiff-find-by-state run-diff state)))) + diff-states))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Presentation code below, business logic above ;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define (diff:stml->string in-stml) + (with-output-to-string + (lambda () + (s:output-new + (current-output-port) + in-stml)))) + +(define (diff:state-status->bgcolor state status) + (match (list state status) + (("CLEAN" _) "#88ff88") + (("BETTER" _) "#33ff33") + (("WORSE" _) "#ff3333") + (("BOTH-BAD" _) "#ff3333") + ((_ "WARN") "#ffff88") + ((_ "FAIL") "#ff8888") + ((_ "ABORT") "#ff0000") + ((_ "PASS") "#88ff88") + ((_ "SKIP") "#ffff00") + (else "#ffffff"))) + +(define (diff:test-state-status->diff-report-cell state status) + (s:td 'bgcolor (diff:state-status->bgcolor state status) status)) + +(define (diff:diff-state-status->diff-report-cell state status) + (s:td state 'bgcolor (diff:state-status->bgcolor state status))) + + +(define (diff:megatest-html-logo) + + "
+___  ___                 _            _
+|  \\/  | ___  __ _  __ _| |_ ___  ___| |_
+| |\\/| |/ _ \\/ _` |/ _` | __/ _ \\/ __| __|
+| |  | |  __/ (_| | (_| | ||  __/\\__ \\ |_
+|_|  |_|\\___|\\__, |\\__,_|\\__\\___||___/\\__|
+             |___/
+
") + +(define (diff:megatest-html-diff-logo) + "
+___  ___                 _            _
+|  \\/  | ___  __ _  __ _| |_ ___  ___| |_  |  _ \\(_)/ _|/ _|
+| |\\/| |/ _ \\/ _` |/ _` | __/ _ \\/ __| __| | | | | | |_| |_
+| |  | |  __/ (_| | (_| | ||  __/\\__ \\ |_  | |_| | |  _|  _|
+|_|  |_|\\___|\\__, |\\__,_|\\__\\___||___/\\__| |____/|_|_| |_|
+             |___/
+
") + + +(define (diff:run-id->target+run-name+starttime run-id) + (let* ((target (rmt:get-target run-id)) + (runinfo (rmt:get-run-info run-id)) ; vector of header (list) and result (vector) + (info-hash (alist->hash-table + (map (lambda (x) (cons (car x) (cadr x))) ; make it a useful hash + (zip (vector-ref runinfo 0) (vector->list (vector-ref runinfo 1)))))) + (run-name (hash-table-ref/default info-hash "runname" "N/A")) + (start-time (hash-table-ref/default info-hash "event_time" 0))) + (list target run-name start-time))) + +(define (diff:deliver-diff-report src-run-id dest-run-id + #!key + (html-output-file #f) + (email-subject-prefix "[MEGATEST DIFF]") + (email-recipients-list '()) ) + (let* ((src-info (diff:run-id->target+run-name+starttime src-run-id)) + (src-target (car src-info)) + (src-run-name (cadr src-info)) + (src-start (conc (seconds->string (caddr src-info)) " " (local-timezone-abbreviation))) + (dest-info (diff:run-id->target+run-name+starttime dest-run-id)) + (dest-target (car dest-info)) + (dest-run-name (cadr dest-info)) + (dest-start (conc (seconds->string (caddr dest-info)) " " (local-timezone-abbreviation))) + + + (run-diff (diff:diff-runs src-run-id dest-run-id )) + (test-count (length run-diff)) + (summary-table + (apply s:table 'cellspacing "0" 'border "1" + (s:tr + (s:th "Diff type") + (s:th "% share") + (s:th "Count")) + + (map + (lambda (state-count) + (s:tr + (diff:diff-state-status->diff-report-cell (car state-count) #f) + (s:td 'align "right" (fmt #f + (decimal-align 3 + (fix 2 + (num/fit 6 + (* 100 (/ (cadr state-count) test-count))))))) + (s:td 'align "right" (cadr state-count)))) + (diff:summarize-run-diff run-diff)))) + (meta-table + (s:table 'cellspacing "0" 'border "1" + + (s:tr + (s:td 'colspan "2" + (s:table 'cellspacing "0" 'border "1" + (s:tr + (s:th 'align "LEFT" "") (s:th "SOURCE RUN") (s:th "DESTINATION RUN")) + (s:tr + (s:th 'align "LEFT" "Started") (s:td src-start) (s:td dest-start)) + (s:tr + (s:th 'align "LEFT" "TARGET") (s:td src-target) (s:td dest-target)) + (s:tr + (s:th 'align "LEFT" "RUN NAME") (s:td src-run-name) (s:td dest-run-name))))))) + + (main-table + (apply s:table 'cellspacing "0" 'border "1" + (s:tr + (s:th "Test name") + (s:th "Item Path") + (s:th (conc "SOURCE")) + (s:th (conc "DEST")) + (s:th "Diff")) + (map + (lambda (run-diff-item) + (match run-diff-item + ((test-name item-path (junk-id diff-state diff-status (src-test-id src-state src-status) (dest-test-id dest-state dest-status))) + (s:tr + (s:td test-name) + (s:td item-path) + (diff:test-state-status->diff-report-cell src-state src-status) + (diff:test-state-status->diff-report-cell dest-state dest-status) + (diff:diff-state-status->diff-report-cell diff-state diff-status))) + (else ""))) + (filter (lambda (run-diff-item) + (match run-diff-item + ((test-name item-path (junk-id diff-state diff-status (src-test-id src-state src-status) (dest-test-id dest-state dest-status))) + (not (equal? diff-state "CLEAN"))) + (else #f))) + run-diff)))) + (email-subject (conc email-subject-prefix " " src-target "/" src-run-name" vs. "dest-target"/"dest-run-name)) + (html-body (diff:stml->string (s:body + (diff:megatest-html-diff-logo) + (s:h2 "Summary") + (s:table 'border "0" + (s:tr + (s:td "Diff calculated at") + (s:td (conc (seconds->string) " " (local-timezone-abbreviation)))) + (s:tr + (s:td "MT_RUN_AREA_HOME" ) (s:td *toppath*)) + (s:tr 'valign "TOP" + (s:td summary-table) + (s:td meta-table))) + (s:h2 "Diffs + consistently failing tests") + main-table))) + + ) + (if html-output-file + (with-output-to-file html-output-file (lambda () (print html-body)))) + (when (and email-recipients-list (> (length email-recipients-list) 0)) + (sendmail (string-join email-recipients-list ",") email-subject html-body use_html: #t)) + html-body)) + + + + + +;; (let* ((src-run-name "all57") +;; (dest-run-name "all60") +;; (src-run-id (diff:run-name->run-id src-run-name)) +;; (dest-run-id (diff:run-name->run-id dest-run-name)) +;; (to-list (list "bjbarcla"))) +;; (diff:deliver-diff-report src-run-id dest-run-id email-recipients-list: to-list html-output-file: "/tmp/bjbarcla/zippy.html") +;; ) + +(define (do-diff-report src-target src-runname dest-target dest-runname html-file to-list-raw) + (let* (;;(src-target "nope%") + ;;(src-runname "all57") + ;;(dest-target "%") + ;;(dest-runname "all60") + (src-run-id (diff:target+run-name->run-id src-target src-runname)) + (dest-run-id (diff:target+run-name->run-id dest-target dest-runname)) + ;(html-file "/tmp/bjbarcla/zippy.html") + (to-list (if (string? to-list-raw) (string-split to-list-raw ",:") #f)) + ) + + (cond + ((not src-run-id) + (print "No match for source target/runname="src-target"/"src-runname) + (print "Cannot proceed.") + #f) + ((not dest-run-id) + (print "No match for source target/runname="dest-target"/"dest-runname) + (print "Cannot proceed.") + #f) + (else + (diff:deliver-diff-report src-run-id dest-run-id email-recipients-list: to-list html-output-file: html-file))))) + + Index: docs/Makefile ================================================================== --- docs/Makefile +++ docs/Makefile @@ -1,5 +1,23 @@ +# Copyright 2006-2017, Matthew Welland. +# +# This file is part of Megatest. +# +# Megatest is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# Megatest is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with Megatest. If not, see . +# + ASCPATH = $(shell which asciidoc) EXEPATH = $(shell readlink -f $(ASCPATH)) BINPATH = $(shell dirname $(EXEPATH)) DISPATH = $(shell dirname $(BINPATH)) @@ -13,5 +31,7 @@ fossil add html/* megatest.pdf : megatest.lyx lyx -e pdf2 megatest.lyx +pkts.pdf : pkts.dot + dot -Tpdf pkts.dot -o pkts.pdf DELETED docs/api.html Index: docs/api.html ================================================================== --- docs/api.html +++ /dev/null @@ -1,1019 +0,0 @@ - - - - - -Megatest Web App API Specificiation - - - - - -
-
-
-

Megatest Web App

-
    -
  1. -

    -See runs -

    -
    2. -
  2. -

    -Manage jobs -

    -
    3. -
  3. -

    -Debug -

    -
    4. -
-
-
-
-

Example Abstract

-
-

The Megatest Web App aims to make as much of the power of the dashboard available to the web based user.

-
-
-
-

1. Common

-
-

This is an example endpoint. You will need to use your own cgi server to serve out your megatest runs.

-

Endpoint: http://kiatoa.com/cgi-bin/megatest

-
-

1.1. Error format response

-

All API errors are returned in the following format:

-
-
-

{ "error" : "Error message" }

-
-
-
-

1.2. Get List of Runs

-

URL: <base>/runs

-

Method: GET

-

Filter Params: target, testpatt, offset, limit

-

Response:

-
-
-

[ - { - "run_id" : "1", - "name" : "runname1", - "target" : "target1", - "tests" : - [ - "test": - [ - {"id": 1, "name":test1, "item_path": "", "shortdir": "/temp/foo/bar/target1/runname1/test1", "final_logf": "megatest-rollup-test1.html", "status": "PASS#"} - {"id": 2, "name":test2, "item_path": "", "shortdir": "/temp/foo/bar/target1/runname1/test2", "final_logf": "megatest-rollup-test2.html", "status": "PASS"} - {"id": 3, "name":test3, "item_path": "", "shortdir": "/temp/foo/bar/target1/runname1/test3", "final_logf": "megatest-rollup-test3.html", "status": "PASS"} - ] - ] - }, - { - "run_id" : "2", - "name" : "runname2", - "target" : "target2", - "tests" : - [ - "test: - [ - {"id": 4, "name":[blue]test1, "item_path": "", "shortdir": "/temp/foo/bar/target2/runname2/test1", "final_logf": "megatest-rollup-test1.html", "status": "PASS"} - {"id": 5, "name":[blue]test2, "item_path": "", "shortdir": "/temp/foo/bar/target2/runname2/test2", "final_logf": "megatest-rollup-test2.html", "status": "FAIL"} - {"id": 6, "name":test3, "item_path": "", "shortdir": "/temp/foo/bar/target2/runname2/test3", "final_logf": "megatest-rollup-test3.html", "status": "PASS"} - ] - ] - } -]

-
-
-
-

1.3. Trigger a new Run

-

URL: <base>/runs

-

Method: POST

-

Request Params:

-
-
-

{"target": "target_value", "runname" : "runname", "test_pattern": "optional test pattern"}

-
-

Response:

-

If Error

-
-
-

{ "error" : "Error message" }

-
-

If Success returns the results of the run

-
-
-

[ - { - "run_id" : "2", - "name" : "runname2", - "target" : "target2", - "tests" : - [ - "test: - [ - {"id": 4, "name":[blue]test1, "item_path": "", "shortdir": "/temp/foo/bar/target2/runname2/test1", "final_logf": "megatest-rollup-test1.html", "status": "PASS"} - {"id": 5, "name":[blue]test2, "item_path": "", "shortdir": "/temp/foo/bar/target2/runname2/test2", "final_logf": "megatest-rollup-test2.html", "status": "FAIL"} - {"id": 6, "name":test3, "item_path": "", "shortdir": "/temp/foo/bar/target2/runname2/test3", "final_logf": "megatest-rollup-test3.html", "status": "PASS"} - ] - ] - } -]

-
-
-
-

1.4. Get perticular Run

-

URL: <base>/runs/:id

-

Method: GET

-

Filter Params: testpatt

-

Response:

-
-
-

[ - { - "run_id" : "2", - "name" : "runname2", - "target" : "target2", - "tests" : - [ - "test": - [ - {"id": 4, "name":[blue]test1, "item_path": "", "shortdir": "/temp/foo/bar/target2/runname2/test1", "final_logf": "megatest-rollup-test1.html", "status": "PASS"} - {"id": 5, "name":[blue]test2, "item_path": "", "shortdir": "/temp/foo/bar/target2/runname2/test2", "final_logf": "megatest-rollup-test2.html", "status": "FAIL"} - {"id": 6, "name":test3, "item_path": "", "shortdir": "/temp/foo/bar/target2/runname2/test3", "final_logf": "megatest-rollup-test3.html", "status": "PASS"} - ] - ] - } -]

-
-
-
-

1.5. Re-execute a run

-

URL: <base>/runs/:id

-

Method: PUT/PATCH

-

Request Params: {"testpatt" : "pattern"}

-

Response:

-
-
-

[ - { - "run_id" : "2", - "name" : "runname2", - "target" : "target2", - "tests" : - [ - "test": - [ - {"id": 4, "name":[blue]test1, "item_path": "", "shortdir": "/temp/foo/bar/target2/runname2/test1", "final_logf": "megatest-rollup-test1.html", "status": "PASS"} - {"id": 5, "name":[blue]test2, "item_path": "", "shortdir": "/temp/foo/bar/target2/runname2/test2", "final_logf": "megatest-rollup-test2.html", "status": "FAIL"} - {"id": 6, "name":test3, "item_path": "", "shortdir": "/temp/foo/bar/target2/runname2/test3", "final_logf": "megatest-rollup-test3.html", "status": "PASS"} - ] - ] - } -]

-
-
-
-

1.6. Get List of tests within a run

-

URL: <base>/runs/:id/tests

-

Method: GET

-

Response:

-
-
-

[ - "tests" : - [ - {"id": 4, "name":[blue]test1, "item_path": "", "shortdir": "/temp/foo/bar/target2/runname2/test1", "final_logf": "megatest-rollup-test1.html", "status": "PASS"} - {"id": 5, "name":[blue]test2, "item_path": "", "shortdir": "/temp/foo/bar/target2/runname2/test2", "final_logf": "megatest-rollup-test2.html", "status": "FAIL"} - {"id": 6, "name":test3, "item_path": "", "shortdir": "/temp/foo/bar/target2/runname2/test3", "final_logf": "megatest-rollup-test3.html", "status": "PASS"} - ] -]

-
-
-
-

1.7. Re-execute a test within a run

-

URL: <base>/runs/:id/tests/:id

-

Method: PUT/PATCH

-

Response:

-
-
-

{"id": "4", "name":"test1", "item_path": "", "shortdir": "/temp/foo/bar/target2/runname2/test1", "final_logf": "megatest-rollup-test1.html", "status": "PASS"}

-
-
-
-

1.8. Get perticular test that belongs to a Runs

-

URL: <base>/runs/:id/tests/:id

-

Method: GET

-

Response:

-
-
-

{"id": "4", "name":"test1", "item_path": "", "shortdir": "/temp/foo/bar/target2/runname2/test1", "final_logf": "megatest-rollup-test1.html", "status": "PASS"}

-
-
-
-
-
-

2. Notes

-
-

Misc …

-
    -
  1. -

    -blah -

    -
    2. -
  2. -

    -baz -

    -
    3. -
-
-
-
-
- - - Index: docs/api.txt ================================================================== --- docs/api.txt +++ docs/api.txt @@ -15,10 +15,29 @@ ---------------- The Megatest Web App aims to make as much of the power of the dashboard available to the web based user. :numbered: + +// Copyright 2006-2017, Matthew Welland. +// +// This file is part of Megatest. +// +// Megatest is free software: you can redistribute it and/or modify +// it under the terms of the GNU General Public License as published by +// the Free Software Foundation, either version 3 of the License, or +// (at your option) any later version. +// +// Megatest is distributed in the hope that it will be useful, +// but WITHOUT ANY WARRANTY; without even the implied warranty of +// MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +// GNU General Public License for more details. +// +// You should have received a copy of the GNU General Public License +// along with Megatest. If not, see . + + Common ------ This is an example endpoint. You will need to use your own cgi server to serve out your megatest runs. @@ -39,10 +58,12 @@ URL: /runs Method: GET Filter Params: target, testpatt, offset, limit + +Megatest Cmd: megatest -start-dir -list-runs % -target % -dumpmode json -fields runs:runname,id+tests:state,status:id Response: ================== @@ -84,10 +105,12 @@ URL: /runs Method: POST +Megatest Cmd: megatest -runtests % -target :runname -run + Request Params: ================== {"[blue]#target#": "target_value", "[blue]#runname#" : "runname", "[blue]#test_pattern#": "optional test pattern"} ================== @@ -127,10 +150,13 @@ URL: /runs/:id Method: GET Filter Params: testpatt + +Megatest Cmd: megatest -start-dir -list-runs -target % -dumpmode json -fields runs:runname,id+tests:state,status:id + Response: ================== [ @@ -188,10 +214,13 @@ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ URL: /runs/:id/tests Method: GET + +Megatest Cmd: megatest -start-dir -list-runs -target % -dumpmode json -fields runs:runname,id+tests:state,status:id + Response: ================== [ "[red]#tests#" : @@ -222,10 +251,13 @@ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ URL: /runs/:id/tests/:id Method: GET + +Megatest Cmd: megatest -start-dir -list-runs -target % -testpattern -dumpmode json -fields runs:runname,id+tests:state,status:id + Response: ================== {"[blue]#id#": "4", "[blue]#name#":"test1", "[blue]#item_path#": "", "[blue]#shortdir#": "/temp/foo/bar/target2/runname2/test1", "[blue]#final_logf#": "megatest-rollup-test1.html", "[blue]#status#": "PASS"} ADDED docs/api_access_methods_evolution.ods Index: docs/api_access_methods_evolution.ods ================================================================== --- /dev/null +++ docs/api_access_methods_evolution.ods cannot compute difference between binary files ADDED docs/architecture-brainstorming.fig Index: docs/architecture-brainstorming.fig ================================================================== --- /dev/null +++ docs/architecture-brainstorming.fig @@ -0,0 +1,118 @@ +#FIG 3.2 Produced by xfig version 3.2.5-alpha5 +Landscape +Center +Inches +Letter +100.00 +Single +-2 +# Copyright 2006-2017, Matthew Welland. +# +# This file is part of Megatest. +# +# Megatest is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# Megatest is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with Megatest. If not, see . +1200 2 +6 1425 2475 2925 4050 +1 2 0 1 0 7 50 -1 -1 0.000 1 0.0000 2175 2812 750 263 1425 3075 2925 2550 +1 2 0 1 0 7 50 -1 -1 0.000 1 0.0000 2175 3713 750 263 1425 3976 2925 3451 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2 + 1425 2850 1425 3750 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2 + 2925 2850 2925 3750 +-6 +6 8775 2625 10275 4200 +1 2 0 1 0 7 50 -1 -1 0.000 1 0.0000 9525 2962 750 263 8775 3225 10275 2700 +1 2 0 1 0 7 50 -1 -1 0.000 1 0.0000 9525 3863 750 263 8775 4126 10275 3601 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2 + 8775 3000 8775 3900 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2 + 10275 3000 10275 3900 +-6 +6 450 750 1950 2325 +1 2 0 1 0 7 50 -1 -1 0.000 1 0.0000 1200 1087 750 263 450 1350 1950 825 +1 2 0 1 0 7 50 -1 -1 0.000 1 0.0000 1200 1988 750 263 450 2251 1950 1726 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2 + 450 1125 450 2025 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2 + 1950 1125 1950 2025 +-6 +6 11775 5100 13275 6675 +1 2 0 1 0 7 50 -1 -1 0.000 1 0.0000 12525 5437 750 263 11775 5700 13275 5175 +1 2 0 1 0 7 50 -1 -1 0.000 1 0.0000 12525 6338 750 263 11775 6601 13275 6076 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2 + 11775 5475 11775 6375 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2 + 13275 5475 13275 6375 +-6 +6 225 4950 11250 9225 +6 4125 6300 5625 7875 +1 2 0 1 0 7 50 -1 -1 0.000 1 0.0000 4875 6637 750 263 4125 6900 5625 6375 +1 2 0 1 0 7 50 -1 -1 0.000 1 0.0000 4875 7538 750 263 4125 7801 5625 7276 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2 + 4125 6675 4125 7575 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2 + 5625 6675 5625 7575 +-6 +6 9000 5700 10500 7275 +1 2 0 1 0 7 50 -1 -1 0.000 1 0.0000 9750 6037 750 263 9000 6300 10500 5775 +1 2 0 1 0 7 50 -1 -1 0.000 1 0.0000 9750 6938 750 263 9000 7201 10500 6676 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2 + 9000 6075 9000 6975 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2 + 10500 6075 10500 6975 +-6 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 1 1 2 + 0 0 1.00 60.00 120.00 + 0 0 1.00 60.00 120.00 + 5850 7050 8775 6375 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 225 4950 11250 4950 11250 9225 225 9225 225 4950 +4 0 0 50 -1 0 12 0.0000 4 150 780 9300 5325 IDEA #1\001 +4 0 0 50 -1 0 12 0.0000 4 195 2160 3975 8100 megatest.db in main area\001 +4 0 0 50 -1 0 12 0.0000 4 195 2400 8625 7350 megatest.db in satellite area\001 +4 0 0 50 -1 0 12 0.0000 4 195 1740 8850 7650 (compatible targets)\001 +4 0 0 50 -1 0 12 0.0000 4 150 765 3900 8775 NEEDS:\001 +4 0 0 50 -1 0 12 0.0000 4 195 5565 3900 9030 enhancements to dashboard to make viewing mulitple areas easy\001 +-6 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 1 0 2 + 0 0 1.00 60.00 120.00 + 2925 3225 8700 3300 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 14700 4950 16500 4950 16500 6900 14700 6900 14700 4950 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 1 0 2 + 0 0 1.00 60.00 120.00 + 13275 5925 14700 5925 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 1 0 2 + 0 0 1.00 60.00 120.00 + 16500 6000 17625 6000 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 17625 4050 20250 4050 20250 7875 17625 7875 17625 4050 +2 4 0 1 0 7 50 -1 -1 0.000 0 0 7 0 0 5 + 14325 5850 14325 4950 13575 4950 13575 5850 14325 5850 +2 4 0 1 0 7 50 -1 -1 0.000 0 0 7 0 0 5 + 17550 5925 17550 5025 16575 5025 16575 5925 17550 5925 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 225 300 11250 300 11250 4725 225 4725 225 300 +4 0 0 50 -1 0 12 0.0000 4 195 1440 1275 4425 tmp megatest.db\001 +4 0 0 50 -1 0 12 0.0000 4 195 1065 8775 4500 megatest.db\001 +4 0 0 50 -1 0 12 0.0000 4 150 1065 750 2475 ref database\001 +4 0 0 50 -1 0 12 0.0000 4 150 510 9300 825 NOW\001 +4 0 0 50 -1 0 12 0.0000 4 150 210 12300 7050 db\001 +4 0 0 50 -1 0 12 0.0000 4 150 525 15150 7125 cache\001 +4 0 0 50 -1 0 12 0.0000 4 195 600 18225 8100 display\001 +4 0 0 50 -1 0 12 0.0000 4 150 390 13650 5250 filter\001 +4 0 0 50 -1 0 12 0.0000 4 150 255 13650 5505 via\001 +4 0 0 50 -1 0 12 0.0000 4 195 240 13650 5760 sql\001 +4 0 0 50 -1 0 12 0.0000 4 150 315 16725 5325 2nd\001 +4 0 0 50 -1 0 12 0.0000 4 150 390 16725 5580 filter\001 Index: docs/dashboard.png ================================================================== --- docs/dashboard.png +++ docs/dashboard.png cannot compute difference between binary files DELETED docs/html/dashboard-test.png Index: docs/html/dashboard-test.png ================================================================== --- docs/html/dashboard-test.png +++ /dev/null cannot compute difference between binary files DELETED docs/html/dashboard.png Index: docs/html/dashboard.png ================================================================== --- docs/html/dashboard.png +++ /dev/null cannot compute difference between binary files DELETED docs/html/megatest.html Index: docs/html/megatest.html ================================================================== --- docs/html/megatest.html +++ /dev/null @@ -1,1717 +0,0 @@ - - - - - - - - -Megatest User Manual - - -
-
- -
-
- -
-
- -
-

-Megatest User Manual -

-

-Matthew Welland -

-

-Jan. 29, 2012 -

-
-


-

-©2011 Matthew Welland. All rights reserved. -
-
-Megatest is free software released under the General Public License v2.0. Please see the file COPYING in the source distribution for details. -
-
-
Email: matt@kiatoa.com. -
-
-Web: www.kiatoa.com/fossils/megatest -
-
-
This document is believed to be acurate at the time of writing but as with any opensource project the source code itself is the reference. It is the responsibility of the end user to validate that the code will perform as they expect. The author assumes no responsibility for any inaccuracies that this document may contain. In no event will Matthew Welland be liable for direct, indirect, special, exemplary, incidental, or consequential damages resulting from any defect or omission in this document, even if advised of the possibility of such damages. -
-
-This document is a snapshot in time and Megatest software has likely changed since publication. This document and Megatest may be improved at any time, without notice or obligation. -
-
-


-

- -
-

-Megatest/document Revision History -

-
-Notable revisions of the software are occasionally documented here. -
-
-
- - - - - - - - - - - - - - - - -
-Version - -Author - -Description - -Date -
-v1.25 - -matt - -converted to new document template - -\thedate -
- -
- -
-
-


-

-
-
-Table of Contents -
-
-
-Section: Megatest/document Revision History -
-
-Section 1: Introduction -
-
-
-Subsection 1.1: Megatest design philosophy -
-
-Subsection 1.2: Megatest architecture -
-
-
-Section 2: Installation -
-
-
-Subsection 2.1: Dependencies -
-
-Subsection 2.2: Build and Install -
-
-
-Section 3: Setup -
-
-
-Subsection 3.1: Create megatest.config -
-
-Subsection 3.2: Create runconfigs.config -
-
-Subsection 3.3: Create the tests directory and your first test -
-
-Subsection 3.4: Create the testconfig file for your test -
-
-Subsection 3.5: Create your test running script, main.sh -
-
-Subsection 3.6: Run megatest and watch your run progress -
-
-
-Section 4: Choose Flow or Unstructured Run? -
-
-Section 5: How to Write Tests -
-
-
-Subsection 5.1: A Simple Test with one Step -
-
-Subsection 5.2: Create your testconfig file -
-
-Subsection 5.3: Create the main.csh script -
-
-Subsection 5.4: Simple Test with Multiple Steps -
-
-
-Section 6: Simple Test with Multiple Steps, Some in Parallel -
-
-
-Subsection 6.1: The Makefile -
-
-Subsection 6.2: The main.csh file -
-
-
-Section 7: Simple Test with Iteration -
-
-
-Subsection 7.1: Update your testconfig file for iteration -
-
-Subsection 7.2: Rewrite your main.csh for iteration -
-
-Subsection 7.3: Tests with Inter-test dependencies -
-
-Subsection 7.4: Rolling up Miscellaneous Data -
-
-Subsection 7.5: Rolling up Runs -
-
-
-Section 8: Dashboard -
-
-Section 9: Generating an OpenDocument Spreadsheet from the Database -
-
-Section 10: Introspection -
-
-
-Subsection 10.1: Getting previous test paths -
-
-
-Section 11: Flows -
-
-Section 12: Flow Specification and Running (Not released yet) -
-
-
-Subsection 12.1: Write your flow file -
-
-Subsection 12.2: Run the flow -
-
-
-Section 13: Monitor based running -
-
-
-Subsection 13.1: Monitor logic -
-
-
-Section 14: Reference -
-
-
-Subsection 14.1: Configuration file Syntax -
-
-
-Subsubsection 14.1.1: Sections -
-
-Subsubsection 14.1.2: Variables -
-
-Subsubsection 14.1.3: Includes -
-
-Subsubsection 14.1.4: Setting a variable by running a command -
-
-Subsubsection 14.1.5: Notes -
-
-
-Subsection 14.2: Environment variables -
-
-Subsection 14.3: megatest.config -
-
-Subsection 14.4: runconfigs.config file -
-
-Subsection 14.5: Writing tests -
-
-
-Subsubsection 14.5.1: testconfig file -
-
-Subsubsection 14.5.2: Command line -
-
-
-
-Appendix A: Data -
-
-Appendix B: References -
-
- -
- -
-
-


-

- -
-

-1 Introduction -

-

-1.1 Megatest design philosophy -

-
-Megatest is intended to provide the minimum needed resources to make writing a suite of tests and implementing continuous build for software, design engineering or process control (via owlfs for example) without being specialized for any specific problem space. Megatest in of itself does not know what constitutes a PASS or FAIL of a test. In most cases megatest is best used in conjunction with logpro or a similar tool to parse, analyze and decide on the test outcome. -
-

-1.2 Megatest architecture -

-
-All data to specify the tests and configure the system is stored in plain text files. All system state is stored in an sqlite3 database. Tests are launched using the launching system available for the distributed compute platform in use. A template script is provided which can launch jobs on local and remote Linux hosts. Currently megatest uses the network filesystem to “call home” to your master sqlite3 database. -
-

-2 Installation -

-

-2.1 Dependencies -

-
-Chicken scheme and a number of “eggs” are required for building megatest. See the file utils/installall.sh for an automated way to install the dependencies on Linux. -
-

-2.2 Build and Install -

-
-Run “make test” to create the megatest executable. You may wish to copy the executable to a centrally accessible location. -
-

-3 Setup -

-

-3.1 Create megatest.config -

-
-Create the file megatest.config using the megatest.config template from the tests directory. At a minimum you need the following: -
-
-
-
# Fields are the keys under which your test runs are organized
-[fields]
-field1 TEXT
-field2 TEXT
-​
-[jobtools]
-# The launcher launches jobs to the local or remote hosts,
-# the job is managed on the target host by megatest,
-# comment out launcher to run local only. An example launcher
-# "nbfake" can be found in the utils directory. 
-launcher nbfake
-​
-# The disks section specifies where the tests will be run. As you
-# run out of space in a partition you can add additional disks
-# entries.
-# Format is:
-# name /path/to/area 
-[disks]
-disk1 /tmp 
-
-
- -
-

-3.2 Create runconfigs.config -

-
-This file is used to set environment variables that are run specific. You can simply create an empty file to start. -
-
-
-
# runconfigs.config
-
-
- -
-

-3.3 Create the tests directory and your first test -

-
-
-
mt
-|-- megatest.config
-|-- runconfigs.config
-‘-- tests
-    ‘-- mytest
-        |-- main.sh
-        ‘-- testconfig
-
-
- -
-

-3.4 Create the testconfig file for your test -

-
-
-
[setup]
-runscript main.sh
-
-
- -
-

-3.5 Create your test running script, main.sh -

-
-
-
#!/bin/bash
-​
-$MT_MEGATEST -runstep mystep1 "sleep 20;echo Done" -m "mystep1 is done"
-$MT_MEGATEST -test-status :state COMPLETED :status PASS -m "This is a comment"
-
-
- -
-

-3.6 Run megatest and watch your run progress -

-
-
-
megatest :field1 abc :field2 def :runname 2011week08.4a -runall
-​
-watch megatest -list-runs %
-​
-# OR use the dashboard
-​
-dashboard &
-
-
- -
-

-4 Choose Flow or Unstructured Run? -

-
-A flow is a structured and specifically sequenced set of tests. See the Flows chapter to understand the difference. -
-

-5 How to Write Tests -

-

-5.1 A Simple Test with one Step -

-
-
-
mkdir simpletest
-cd simpletest
-
-
- -
-

-5.2 Create your testconfig file -

-
-
-
# testconfig
-​
-[setup]
-runscript main.csh
-
-
- -
-

-5.3 Create the main.csh script -

-
-Note: Using csh is NOT recommended. Use bash, perl, ruby, zsh or anything other than csh. We use csh here because it is popular in the EDA industry for which Megatest was originally created. -
-
-
-
-
#!/bin/tcsh -x
-​
-# run the cpu1 simulation.
-#   The step name is "run_simulation"
-#   The commandline being run for this step is "runsim cpu1"
-#   The logpro file to validate the output from the run is "runsim.logpro"
-​
-$MT_MEGATEST -runstep run_simulation -logpro runsim.logpro "runsim cpu1"
-$MT_MEGATEST -test-status :state COMPLETED :status $?
-
-
- -
- -
-
-You can now run megatest and the created test directory will contain the new files “run_simulation.html” and “run_simulation.log”. If you are using the dashboard you can click on the run and then push the “View log” button to view the log file in firefox. -
-

-5.4 Simple Test with Multiple Steps -

-
-To run multiple steps simply add them to the main.csh file. Here we add a step to test “cpu2”. The second step that tests cpu2 will only run after the step that tested “cpu1” completes. -
-
-
-
#!/bin/tcsh -x
-​
-# run the cpu1 simulation.
-#   The step name is "run_simulation"
-#   The commandline being run for this step is "runsim cpu1"
-#   The logpro file to validate the output from the run is "runsim.logpro"
-​
-$MT_MEGATEST -runstep run_simulation_cpu1 -logpro runsim.logpro "runsim cpu1" && \
-$MT_MEGATEST -runstep run_simulation_cpu2 -logpro runsim.logpro "runsim cpu2"
-$MT_MEGATEST -test-status :state COMPLETED :status $?
-
-
- -
-

-6 Simple Test with Multiple Steps, Some in Parallel -

-

-6.1 The Makefile -

-
-A good way to run steps in parallel within a single test, especially when there are following steps, is to use the Unix Make utility. Writing Makefiles is beyond the scope of this document but here is a minimal example that will run “runsim cpu1” and “runsim cpu2” in parallel. For more information on make try “info make” at the Linux command prompt. -
-
-
-
# Example Makefile to run two steps in parallel
-​
-RTLDIR=/path/to/rtl
-CPUS = cpu1 cpu2
-​
-run_simulation_$(CPUS).html : $(RTLDIR)/$(CPUS)
-	$(MT_MEGATEST) -runstep run_simulation_$(CPUS) -logpro runsim.logpro "runsim $(CPUS)
-
-
- -
-

-6.2 The main.csh file -

-
-
-
#!/bin/tcsh -x
-​
-# run the cpu1 and cpu2 simulations in parallel. 
-# The -j parameter tells make how many jobs it may run in parallel
-​
-

-make -j 2 
-

-
-$MT_MEGATEST -test-status :state COMPLETED :status $?
-
-
- -
-

-7 Simple Test with Iteration -

-
-Since no jobs run after the cpu1 and cpu2 simulations in this test it is possible to use iterated mode. -
-

-7.1 Update your testconfig file for iteration -

-
-
-
[setup]
-runscript main.csh
-

-
-

-
-[items]
-CPU cpu1 cpu2
-
-
- -
-

-7.2 Rewrite your main.csh for iteration -

-
-
-
#!/bin/tcsh -x
-
-# run the cpu simulation but now use the environment variable $CPU
-# to select what cpu to run the simulation against
-
-$MT_MEGATEST -runstep run_simulation -logpro runsim.logpro "runsim $CPU"
-# As of version 1.07 Megatest automatically converts a status of "0"
-# to "PASS", any other number to "FAIL" and directly uses the value of
-# a string passed in.
-$MT_MEGATEST -test-status :state COMPLETED :status $?
-
-
- -
-

-7.3 Tests with Inter-test dependencies -

-
-Sometimes a test depends on the output from a previous test or it may not make sense to run a test is another test does not complete with status “PASS”. In either of these scenarios you can use the “waiton” keyword in your testconfig file to indicate that this test must wait on one or more tests to complete before being launched. In this example there is no point in running the “system” test if the “cpu” and “mem” tests either do not complete or complete but with status “FAIL”. -
-
-
-
# testconfig for the "system" test
-[setup]
-runscript main.csh
-waiton cpu mem
-
-
- -
-

-7.4 Rolling up Miscellaneous Data -

-
-Use the -load-test-data switch to roll up arbitrary data from a test into the test_data table. -
-
-
-
# Fields are:
-# category,variable,value,expected,tol,units,comment,status
-​
-$MT_MEGATEST -load-test-data << EOF
-foo,bar,1.2,1.9,>
-foo,rab,1.0e9,10e9,1e9
-foo,bla,1.2,1.9,<
-foo,bal,1.2,1.2,<,,Check for overload
-foo,alb,1.2,1.2,<=,Amps,This is the high power circuit test
-foo,abl,1.2,1.3,0.1
-foo,bra,1.2,pass,silly stuff
-faz,bar,10,8mA,,,"this is a comment"
-EOF
-
-
- -
-
-New entries are keyed on the category and variable. If a new record is inserted with a category and variable that have already been used the new record will replace the old record. -
-
-Where value, expected and tol are specified the behavior is as follows. -
-
    -
  • -If value, expected and tol are numbers then status is calculated as PASS if (expected-tol) <= value <= (expected+tol) -
    • -
  • -If value and expected are numbers and tol is >, <, >= or <= then value is compared with expected using the operator given by tol -
    • -
  • -If status is specified its value overrides the above calculations. -
    • - -
-

-7.5 Rolling up Runs -

-
-To roll up a number of tests in a sequence of runs to a single run use the -rollup command. -
-
-
-
megatest -rollup :sysname ubuntu :fsname nfs :datapath none :runname rollup_ww38
-
-
- -
-
-All keys must be specified and the runname is the name of the run that will be created. All paths are kept original inside the database. When -remove-runs is used to delete runs the data is not deleted if there are rollups that refer to the data. -
-

-8 Dashboard -

-
-
-
> dashboard &
-
-
- -
-
-figure dashboard.png - -
-
-Pushing one of the buttons on the main dashboard will bring up the test specific dashboard. Values are updated in semi-real time as the test runs. -
-
-figure dashboard-test.png - -
-

-9 Generating an OpenDocument Spreadsheet from the Database -

-
-And OpenDocument multi-paned spreadsheet can be generated from the megatest.db file by running -extract-ods -
-
-
-
megatest -extract-ods results.ods :runname % 
-
-
- -
-
-You can optionally specify the keys for your database to limit further the runs to extract into the spreadsheet. The first sheet contains all the run data and subsequent sheets contain data rolled up for the individual tests. -
-

-10 Introspection -

-

-10.1 Getting previous test paths -

-
-
-
megatest -test-paths -target %/%/% :runname % -testpatt % -itempatt % :status PASS 
-
-
- -
-

-11 Flows -

-
-A flow specifies the tests to run, the order and dependencies and is managed by a running megatest process. -
-

-12 Flow Specification and Running (Not released yet) -

-

-12.1 Write your flow file -

-
-flows/<flowname>.config -
-
-
-
# Flow: <flowname>
-[flowconfig]
-# turn on item level dependencies
-itemdeps on
-​
-[flowsteps]
-# <testname>[,<predecessor>]
-​
-# Run the test "copydata"
-copydata
-​
-# Run the test "setup" after copydata completes with PASS, WARN or WAIVE
-setup,copydata
-​
-# once the test "setup" completes successfully run sim1, sim2 and sim3
-sim1,setup
-sim2,setup
-sim3,setup
-
-
- -
-

-12.2 Run the flow -

-
-
-
megatest -runflow <flowname> :FIELD1 val1 :FIELD2 val2 :runname wk32.4
-
-
- -
-

-13 Monitor based running -

-

-13.1 Monitor logic -

-
-Note: The monitor is usable but incomplete as of Megatest v1.31. Click on the “Monitor” button on the dashboard to start the monitor and give it a try. -
-
-figure monitor-state-diagram.png - -
-

-14 Reference -

-

-14.1 Configuration file Syntax -

-
-Note: whitespace is preserved including at the end of line. Ensure your entries only have whitespace at the end of line when needed to avoid problems. -
-

-14.1.1 Sections -

-
-
-
[section name]
-
-
- -
-
-This creates a section named “section name” -
-

-14.1.2 Variables -

-
-
-
VARX has this value
-
-
- -
-
-The variable “VARX” will have the value “has this value” -
-

-14.1.3 Includes -

-
-
-
[include filename]
-
-
- -
-
-The file named “filename” will be included as if part of the calling file. NOTE: This means no section can be named “include “ (with the whitespace). -
-

-14.1.4 Setting a variable by running a command -

-
-
-
VARNAME [system ls /tmp]
-
-
- -
-
-The variable “VARNAME” will get a value created by the Unix command “ls /tmp”. All lines of output from the command will be joined with a space. -
-

-14.1.5 Notes -

-
    -
  • -Some variables are infered as lists. Each token on the line separated by whitespace will be member of the list. -
    • -
  • -Comments (lines starting with #) and blank lines are ignored. -
    • - -
-

-14.2 Environment variables -

-
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-Variable - -Purpose -
-MT_CMDINFO - -Conveys test variables to the megatest test runner. -
-MT_TEST_RUN_DIR - -Directory assigned by megatest for the test to run. -
-MT_TEST_NAME - -Name of the test, corrosponds to the directory name under tests. -
-MT_ITEM_INFO - -Iterated tests will set this to a sequence of key/values ((KEY val) ...) -
-MT_RUN_AREA_HOME - -Directory where megatest was launched from and where the tests code can be found -
-MT_RUNNAME - -Name of this run as set by the :runname parameter -
-MT_MEGATEST - -Path/Filename to megatest executable. Found either from called path or but using the “exectuable” keyword in the [setup] section. -
-<field1> .... - -The field values as set on the megatest -runall command line (e.g. :field1 abc) -
- -
-

-14.3 megatest.config -

-
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-section - -variable - -value - -required - -comment -
-[setup] - -max_concurrent_jobs - -if variable is not defined no limit on jobs - -no - - -
- - -executable - -full path to megatest binary - -no - -Use only if necessary, megatest will extract the location from where it used to launch and add append that to the PATH for test runs. -
- - -runsdir - -full path to where the link tree to all runs will be created - -no - -Because your runs may be spread out over several disk partitions a central link tree is created to make finding all the runs easy. -
-[fields] - -string of letters, numbers and underscore - -string of letters, numbers and underscore - -at least one - - -
-[jobtools] - -launcher - -command line used to launch jobs - the job command (megatest -execute) will be appended to this - -no - - -
- - -workhosts - -list of hostnames to run jobs on NOT SUPPORTED RIGHT NOW - -n/a - - -
-[jobgroups] - -string of letters, numbers and underscore - -number - -no - -Control number of jobs allowed to concurrently run in categories. See [jobgroup] in testconfig -
-[env-override] - -string of letters, numbers and underscore - -any string - -no - -These are set on the test launching machine, not the test running machine. Typical usage is to control the host or run queue for launching tests. These values will not be seen by the test when it runs. -
-[disks] - -string of letters, numbers and underscore - -a valid path writable by the test launching process and by the test process - -yes - -The disk usage balancing algorithm is to choose the disk with the least space for each test run. -
- -
-

-14.4 runconfigs.config file -

-
- - - - - - - - - - - - - - - - - - - - - - - - - - -
-section - -variable - -value - -required? - -comment -
-[default] - -string of letters, numbers and underscore - -any - -no - -variables set in this section will be available for all runs, defining the same variable in another section will override the value from the default section -
-[field1value/field2value...] - -string of letters, numbers and underscore - -any - -no - -the values in this section will be set for any run where field1 is field1value, field2 is field2value and fieldN is fieldNvalue. -
- -
-
-Example: a test suite that checks that a piece of software works correctly for different customer configurations and locations each of which is done as a separate release regression run. The fields, CUSTOMER and LOCATION were chosen. The following runconfigs.config file would set some variables specific to runs for megacorp in India and femtocorp in the Cook Islands and New Zealand: -
-
-
-
# runconfigs.config
-[default]
-ENCRYTION true
-​
-[megacorp/india]
-TESTPATH /nfs/testing/megacorp_runs
-​
-[femtocorp/cook_islands]
-ENCRYTION false
-TESTPATH /afs/kiatoa/testing/cook_islands
-​
-[femtocorp/new_zealand]
-TESTPATH /afs/kiatoa/testing/new_zealand
-​
-[megacorp/new_zealand]
-TESTPATH /nfs/testing/megacorp_runs
-
-
- -
-
-Running megatest like this: -
-
-megatest :CUSTOMER megacorp :LOCATION new_zealand :runname week12_2011_run1 -runall -
-
-Would set: -
-
-ENCRYPTION true -
-
-TESTPATH /nfs/testing/megacorp_runs -
-

-14.5 Writing tests -

-

-14.5.1 testconfig file -

-
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-section - -variable - -value - -required? - -comments -
-[setup] - -runscript - -name of script to execute for this test - -yes - -The script must be executable and either provide the full path or put a copy at the top of your test directory -
-[requirements] - -waiton - -list of valid test names - -no - -This test will not run until the named tests are state completed and status PASS -
- - -jobgroup - - - - - - -
-[items] - -any valid - -list of values - -no - -The test will be repeated once for each item with the variable name set to the value. If there is more than one variable then the test will be run against all unique combinations of the values -
-[eztests] - -any valid - -stepname command - -no - -Use in addition to or instead of runscript for easy implementation of steps. If <stepname>.logpro exists it will be applied to the <stepname>.log and resulting exit code will be used to determine PASS/FAIL/WARN -
- -
-

-14.5.2 Command line -

-
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-switch or param - -parameter - -purpose - -comments -
--h - - - -brief help - - -
--runall - - - -run all tests - - -
--runtests - -test1,test2,... - -run one or more tests - - -
--step - -stepname - -record a step - -requires :state and :status -
--test-status - - - -record the test status - -requires :state and :status -
--setlog - -logfilename - -set the logfile name for a test - -path is assumed to be relative to the test run directory -
--set-toplog - -logfilename - -set the logfile name for the top test in an iterated test run - -each sub test can have its own logfile set -
--m - -“comment” - -sets a comment for the step, test or run - - -
-:runname - -[a-zA-Z0-9_-]+ - -directory in which this run will be stored in the test run area - - -
-:state - -any value - -Set the step or test state, this is stored in the state field in the steps or tests table respectively - -For tests Megatest recognises “INCOMPLETE”, “COMPLETE” -
-:status - -any value - -Set the step or test status, this is stored in the status field in the steps or tests table respectively - -For tests Megatest recognises “PASS”, “FAIL”, and “CHECK” -
--list-runs - -any value, % is wildcard - -Respects -itempatt and -testpatt for filters - - -
--testpatt - -any value, % is wildcard - - - - -
--itempatt - -any value, % is wildcard - - - - -
--showkeys - - - -Print the keys being used for this database - - -
--force - - - -Test will not re-run if in the “PASS”, “CHECK” or “KILLED”, using -force will force the run to be launched. - -WARNING: The -force switch will bypass any “waiton” dependencies. -
--xterm - - - -Launch an xterm instead of run the test. The xterm will have the environment that the test would see. - - -
--remove-runs - - - -Remove a run, test or subtest from the database and the disk. Cannot be undone. Requires -testpatt, -itempatt, :runname and all keys be specified. - - -
-Test helpers - - - - - - -
--runstep - - - -Used inside a test to run a step, record the start and end of the step and optionally analyze the output using logpro. - - -
--logpro - - - -If using logpro to acess the PASS/FAIL status of the step you specify the logpro file with this parameter. - - -
- -
-

-A Data -

-

-B References -

- -
- -
- - DELETED docs/html/monitor-state-diagram.png Index: docs/html/monitor-state-diagram.png ================================================================== --- docs/html/monitor-state-diagram.png +++ /dev/null cannot compute difference between binary files ADDED docs/inprogress/graph-draw-arch.fig Index: docs/inprogress/graph-draw-arch.fig ================================================================== --- /dev/null +++ docs/inprogress/graph-draw-arch.fig @@ -0,0 +1,68 @@ +#FIG 3.2 Produced by xfig version 3.2.5-alpha5 +Landscape +Center +Inches +Letter +100.00 +Single +-2 +1200 2 +# Copyright 2006-2017, Matthew Welland. +# +# This file is part of Megatest. +# +# Megatest is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# Megatest is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with Megatest. If not, see . +6 5700 3075 8400 3675 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 5700 3075 8400 3075 8400 3675 5700 3675 5700 3075 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 9 + 5700 3525 5925 3525 5925 3225 6750 3225 6750 3450 7350 3450 + 7350 3600 8325 3600 8250 3525 +-6 +6 7425 6825 10125 7425 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 7425 6825 10125 6825 10125 7425 7425 7425 7425 6825 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 9 + 7425 7275 7650 7275 7650 6975 8475 6975 8475 7200 9075 7200 + 9075 7350 10050 7350 9975 7275 +-6 +2 4 0 1 0 7 50 -1 -1 0.000 0 0 7 0 0 5 + 3000 4650 3000 3225 600 3225 600 4650 3000 4650 +2 4 0 1 0 7 50 -1 -1 0.000 0 0 7 0 0 5 + 2550 5100 2550 3675 150 3675 150 5100 2550 5100 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 1 0 2 + 0 0 1.00 60.00 120.00 + 3000 3825 5550 3450 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 5475 2400 8475 2400 8475 4650 5475 4650 5475 2400 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 1 0 2 + 0 0 1.00 60.00 120.00 + 7275 4725 8175 6375 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 1 + 8175 6375 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 6225 6300 11025 6300 11025 9000 6225 9000 6225 6300 +2 4 2 1 0 7 50 -1 -1 3.000 0 0 7 0 0 5 + 8850 5850 8850 900 75 900 75 5850 8850 5850 +2 4 0 1 0 7 50 -1 -1 3.000 0 0 7 0 0 5 + 4875 5550 4875 4500 3450 4500 3450 5550 4875 5550 +2 1 0 1 0 7 50 -1 -1 3.000 0 0 -1 1 0 2 + 0 0 1.00 60.00 120.00 + 4500 4500 5475 4200 +4 0 0 50 -1 0 12 0.0000 4 195 915 750 3525 graph data\001 +4 0 0 50 -1 0 12 0.0000 4 195 525 5550 2700 layout\001 +4 0 0 50 -1 0 12 0.0000 4 195 1800 6375 6525 display on dashboard\001 +4 0 0 50 -1 0 12 0.0000 4 195 1065 3525 4875 megatest.db\001 +4 0 0 50 -1 0 12 0.0000 4 195 6150 675 1425 Very slow! Threaded running of procedure: runtimes-tab-layout-updater\001 +4 0 0 50 -1 0 12 0.0000 4 195 2865 8325 6225 fast!runtimes-tab-canvas-updater\001 ADDED docs/inprogress/megatest-architecture-2.fig Index: docs/inprogress/megatest-architecture-2.fig ================================================================== --- /dev/null +++ docs/inprogress/megatest-architecture-2.fig @@ -0,0 +1,44 @@ +#FIG 3.2 Produced by xfig version 3.2.5-alpha5 +Landscape +Center +Inches +Letter +100.00 +Single +-2 +1200 2 +# Copyright 2006-2017, Matthew Welland. +# +# This file is part of Megatest. +# +# Megatest is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# Megatest is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with Megatest. If not, see . +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 750 975 5850 975 5850 7425 750 7425 750 975 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 6000 975 9975 975 9975 7425 6000 7425 6000 975 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 900 1500 5250 1500 5250 2475 900 2475 900 1500 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 900 2625 5250 2625 5250 3675 900 3675 900 2625 +2 3 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 8 + 5325 1500 5325 5850 900 5850 900 7275 5700 7275 5700 1425 + 5250 1425 5325 1500 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 900 3750 5250 3750 5250 4725 900 4725 900 3750 +4 0 0 50 -1 0 12 0.0000 4 165 1170 975 1275 megatest.exe\001 +4 0 0 50 -1 0 12 0.0000 4 150 1275 6150 1275 dashboard.exe\001 +4 0 0 50 -1 0 12 0.0000 4 195 900 1050 1725 run engine\001 +4 0 0 50 -1 0 12 0.0000 4 150 780 975 2850 database\001 +4 0 0 50 -1 0 12 0.0000 4 195 2025 1050 6075 data transport - use http\001 +4 0 0 50 -1 0 12 0.0000 4 195 2325 975 3900 test or launch management\001 ADDED docs/inprogress/megatest-architecture-proposed-2.fig Index: docs/inprogress/megatest-architecture-proposed-2.fig ================================================================== --- /dev/null +++ docs/inprogress/megatest-architecture-proposed-2.fig @@ -0,0 +1,490 @@ +#FIG 3.2 Produced by xfig version 3.2.5-alpha5 +Landscape +Center +Inches +Letter +100.00 +Single +-2 +1200 2 +# Copyright 2006-2017, Matthew Welland. +# +# This file is part of Megatest. +# +# Megatest is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# Megatest is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with Megatest. If not, see . +6 600 1350 1575 2400 +1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 1125 1500 450 150 1125 1500 1575 1650 +1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 1124 2177 450 150 1124 2177 1574 2327 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2 + 675 1575 675 2175 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2 + 1575 1500 1575 2175 +-6 +6 14100 150 19950 6075 +6 14850 1350 15825 2400 +1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 15375 1500 450 150 15375 1500 15825 1650 +1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 15374 2177 450 150 15374 2177 15824 2327 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2 + 14925 1575 14925 2175 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2 + 15825 1500 15825 2175 +-6 +2 4 0 1 0 7 50 -1 -1 0.000 0 0 7 0 0 5 + 17025 4050 17025 3450 15750 3450 15750 4050 17025 4050 +2 1 0 1 0 7 50 -1 -1 3.000 0 0 -1 1 1 2 + 0 0 1.00 60.00 120.00 + 0 0 1.00 60.00 120.00 + 16050 3375 15525 2400 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 15825 5325 17175 5325 17175 5850 15825 5850 15825 5325 +2 1 0 1 0 7 50 -1 -1 3.000 0 0 -1 1 1 2 + 0 0 1.00 60.00 120.00 + 0 0 1.00 60.00 120.00 + 16350 4050 16350 5325 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 17550 4800 18900 4800 18900 5325 17550 5325 17550 4800 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 18375 3900 19725 3900 19725 4425 18375 4425 18375 3900 +2 1 0 1 0 7 50 -1 -1 3.000 0 0 -1 1 1 2 + 0 0 1.00 60.00 120.00 + 0 0 1.00 60.00 120.00 + 16725 4050 17850 4800 +2 1 0 1 0 7 50 -1 -1 3.000 0 0 -1 1 1 2 + 0 0 1.00 60.00 120.00 + 0 0 1.00 60.00 120.00 + 17025 3750 18375 4125 +2 1 0 1 14 7 50 -1 -1 3.000 0 0 -1 1 1 3 + 0 0 1.00 60.00 120.00 + 0 0 1.00 60.00 120.00 + 18975 3900 18075 2625 15900 1875 +2 2 0 1 0 7 50 -1 -1 3.000 0 0 -1 0 0 5 + 14100 150 19950 150 19950 6075 14100 6075 14100 150 +4 0 0 50 -1 0 12 0.0000 4 150 900 15825 3675 rpc-server\001 +4 0 0 50 -1 0 12 0.0000 4 165 270 17475 3825 tcp\001 +4 0 0 50 -1 0 12 0.0000 4 120 315 18525 4125 test\001 +4 0 0 50 -1 0 12 0.0000 4 195 1065 14850 1200 megatest.db\001 +4 0 0 50 -1 0 12 0.0000 4 150 1020 14325 525 basic model\001 +-6 +6 14850 7425 15825 8475 +1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 15375 7575 450 150 15375 7575 15825 7725 +1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 15374 8252 450 150 15374 8252 15824 8402 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2 + 14925 7650 14925 8250 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2 + 15825 7575 15825 8250 +-6 +6 17775 6675 18750 7725 +1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 18300 6825 450 150 18300 6825 18750 6975 +1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 18299 7502 450 150 18299 7502 18749 7652 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2 + 17850 6900 17850 7500 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2 + 18750 6825 18750 7500 +-6 +6 6150 2700 7500 3225 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 6150 2700 7500 2700 7500 3225 6150 3225 6150 2700 +4 0 0 50 -1 0 12 0.0000 4 180 870 6225 2925 run2/test1\001 +-6 +6 2025 675 3000 1725 +1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 2550 825 450 150 2550 825 3000 975 +1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 2549 1502 450 150 2549 1502 2999 1652 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2 + 2100 900 2100 1500 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2 + 3000 825 3000 1500 +-6 +6 675 7275 1650 8325 +1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 1200 7425 450 150 1200 7425 1650 7575 +1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 1199 8102 450 150 1199 8102 1649 8252 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2 + 750 7500 750 8100 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2 + 1650 7425 1650 8100 +-6 +6 3675 6675 4650 7725 +1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 4200 6825 450 150 4200 6825 4650 6975 +1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 4199 7502 450 150 4199 7502 4649 7652 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2 + 3750 6900 3750 7500 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2 + 4650 6825 4650 7500 +-6 +6 900 3825 2175 4425 +2 4 0 1 0 7 50 -1 -1 0.000 0 0 7 0 0 5 + 2175 4425 2175 3825 900 3825 900 4425 2175 4425 +4 0 0 50 -1 0 12 0.0000 4 150 720 1050 4125 server-1\001 +-6 +6 150 5475 1500 6000 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 150 5475 1500 5475 1500 6000 150 6000 150 5475 +4 0 0 50 -1 0 12 0.0000 4 180 870 300 5700 run1/test1\001 +-6 +6 1725 5400 3075 5925 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 1725 5400 3075 5400 3075 5925 1725 5925 1725 5400 +4 0 0 50 -1 0 12 0.0000 4 180 870 1800 5625 run1/test2\001 +-6 +6 5400 5100 6375 6975 +6 5400 5100 6375 6150 +1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 5925 5250 450 150 5925 5250 6375 5400 +1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 5924 5927 450 150 5924 5927 6374 6077 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2 + 5475 5325 5475 5925 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2 + 6375 5250 6375 5925 +-6 +4 0 0 50 -1 0 12 0.0000 4 195 885 5475 6375 postgresql\001 +4 0 0 50 -1 0 12 0.0000 4 195 555 5475 6630 sqlite3\001 +4 0 0 50 -1 0 12 0.0000 4 195 510 5475 6885 mysql\001 +-6 +6 4050 675 6000 2175 +6 4125 900 5100 1950 +1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 4650 1050 450 150 4650 1050 5100 1200 +1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 4649 1727 450 150 4649 1727 5099 1877 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2 + 4200 1125 4200 1725 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2 + 5100 1050 5100 1725 +-6 +4 0 0 50 -1 0 12 0.0000 4 195 1905 4050 2100 pointers to the servers\001 +4 0 0 50 -1 0 12 0.0000 4 150 930 4200 825 monitor.db\001 +-6 +6 8175 4125 8400 8625 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8175 4125 8400 4125 8400 4350 8175 4350 8175 4125 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8175 4350 8400 4350 8400 4575 8175 4575 8175 4350 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8175 4575 8400 4575 8400 4800 8175 4800 8175 4575 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8175 4800 8400 4800 8400 5025 8175 5025 8175 4800 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8175 5025 8400 5025 8400 5250 8175 5250 8175 5025 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8175 5250 8400 5250 8400 5475 8175 5475 8175 5250 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8175 5475 8400 5475 8400 5700 8175 5700 8175 5475 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8175 5700 8400 5700 8400 5925 8175 5925 8175 5700 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8175 5925 8400 5925 8400 6150 8175 6150 8175 5925 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8175 6150 8400 6150 8400 6375 8175 6375 8175 6150 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8175 6375 8400 6375 8400 6600 8175 6600 8175 6375 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8175 6600 8400 6600 8400 6825 8175 6825 8175 6600 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8175 6825 8400 6825 8400 7050 8175 7050 8175 6825 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8175 7050 8400 7050 8400 7275 8175 7275 8175 7050 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8175 7275 8400 7275 8400 7500 8175 7500 8175 7275 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8175 7500 8400 7500 8400 7725 8175 7725 8175 7500 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8175 7725 8400 7725 8400 7950 8175 7950 8175 7725 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8175 7950 8400 7950 8400 8175 8175 8175 8175 7950 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8175 8175 8400 8175 8400 8400 8175 8400 8175 8175 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8175 8400 8400 8400 8400 8625 8175 8625 8175 8400 +-6 +6 8475 4125 8700 8625 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8475 4125 8700 4125 8700 4350 8475 4350 8475 4125 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8475 4350 8700 4350 8700 4575 8475 4575 8475 4350 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8475 4575 8700 4575 8700 4800 8475 4800 8475 4575 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8475 4800 8700 4800 8700 5025 8475 5025 8475 4800 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8475 5025 8700 5025 8700 5250 8475 5250 8475 5025 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8475 5250 8700 5250 8700 5475 8475 5475 8475 5250 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8475 5475 8700 5475 8700 5700 8475 5700 8475 5475 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8475 5700 8700 5700 8700 5925 8475 5925 8475 5700 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8475 5925 8700 5925 8700 6150 8475 6150 8475 5925 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8475 6150 8700 6150 8700 6375 8475 6375 8475 6150 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8475 6375 8700 6375 8700 6600 8475 6600 8475 6375 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8475 6600 8700 6600 8700 6825 8475 6825 8475 6600 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8475 6825 8700 6825 8700 7050 8475 7050 8475 6825 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8475 7050 8700 7050 8700 7275 8475 7275 8475 7050 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8475 7275 8700 7275 8700 7500 8475 7500 8475 7275 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8475 7500 8700 7500 8700 7725 8475 7725 8475 7500 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8475 7725 8700 7725 8700 7950 8475 7950 8475 7725 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8475 7950 8700 7950 8700 8175 8475 8175 8475 7950 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8475 8175 8700 8175 8700 8400 8475 8400 8475 8175 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8475 8400 8700 8400 8700 8625 8475 8625 8475 8400 +-6 +6 8775 4125 9000 8625 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8775 4125 9000 4125 9000 4350 8775 4350 8775 4125 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8775 4350 9000 4350 9000 4575 8775 4575 8775 4350 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8775 4575 9000 4575 9000 4800 8775 4800 8775 4575 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8775 4800 9000 4800 9000 5025 8775 5025 8775 4800 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8775 5025 9000 5025 9000 5250 8775 5250 8775 5025 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8775 5250 9000 5250 9000 5475 8775 5475 8775 5250 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8775 5475 9000 5475 9000 5700 8775 5700 8775 5475 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8775 5700 9000 5700 9000 5925 8775 5925 8775 5700 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8775 5925 9000 5925 9000 6150 8775 6150 8775 5925 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8775 6150 9000 6150 9000 6375 8775 6375 8775 6150 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8775 6375 9000 6375 9000 6600 8775 6600 8775 6375 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8775 6600 9000 6600 9000 6825 8775 6825 8775 6600 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8775 6825 9000 6825 9000 7050 8775 7050 8775 6825 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8775 7050 9000 7050 9000 7275 8775 7275 8775 7050 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8775 7275 9000 7275 9000 7500 8775 7500 8775 7275 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8775 7500 9000 7500 9000 7725 8775 7725 8775 7500 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8775 7725 9000 7725 9000 7950 8775 7950 8775 7725 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8775 7950 9000 7950 9000 8175 8775 8175 8775 7950 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8775 8175 9000 8175 9000 8400 8775 8400 8775 8175 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8775 8400 9000 8400 9000 8625 8775 8625 8775 8400 +-6 +6 9075 4125 9300 8625 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9075 4125 9300 4125 9300 4350 9075 4350 9075 4125 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9075 4350 9300 4350 9300 4575 9075 4575 9075 4350 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9075 4575 9300 4575 9300 4800 9075 4800 9075 4575 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9075 4800 9300 4800 9300 5025 9075 5025 9075 4800 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9075 5025 9300 5025 9300 5250 9075 5250 9075 5025 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9075 5250 9300 5250 9300 5475 9075 5475 9075 5250 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9075 5475 9300 5475 9300 5700 9075 5700 9075 5475 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9075 5700 9300 5700 9300 5925 9075 5925 9075 5700 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9075 5925 9300 5925 9300 6150 9075 6150 9075 5925 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9075 6150 9300 6150 9300 6375 9075 6375 9075 6150 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9075 6375 9300 6375 9300 6600 9075 6600 9075 6375 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9075 6600 9300 6600 9300 6825 9075 6825 9075 6600 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9075 6825 9300 6825 9300 7050 9075 7050 9075 6825 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9075 7050 9300 7050 9300 7275 9075 7275 9075 7050 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9075 7275 9300 7275 9300 7500 9075 7500 9075 7275 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9075 7500 9300 7500 9300 7725 9075 7725 9075 7500 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9075 7725 9300 7725 9300 7950 9075 7950 9075 7725 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9075 7950 9300 7950 9300 8175 9075 8175 9075 7950 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9075 8175 9300 8175 9300 8400 9075 8400 9075 8175 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9075 8400 9300 8400 9300 8625 9075 8625 9075 8400 +-6 +6 9375 4125 9600 8625 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9375 4125 9600 4125 9600 4350 9375 4350 9375 4125 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9375 4350 9600 4350 9600 4575 9375 4575 9375 4350 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9375 4575 9600 4575 9600 4800 9375 4800 9375 4575 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9375 4800 9600 4800 9600 5025 9375 5025 9375 4800 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9375 5025 9600 5025 9600 5250 9375 5250 9375 5025 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9375 5250 9600 5250 9600 5475 9375 5475 9375 5250 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9375 5475 9600 5475 9600 5700 9375 5700 9375 5475 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9375 5700 9600 5700 9600 5925 9375 5925 9375 5700 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9375 5925 9600 5925 9600 6150 9375 6150 9375 5925 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9375 6150 9600 6150 9600 6375 9375 6375 9375 6150 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9375 6375 9600 6375 9600 6600 9375 6600 9375 6375 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9375 6600 9600 6600 9600 6825 9375 6825 9375 6600 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9375 6825 9600 6825 9600 7050 9375 7050 9375 6825 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9375 7050 9600 7050 9600 7275 9375 7275 9375 7050 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9375 7275 9600 7275 9600 7500 9375 7500 9375 7275 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9375 7500 9600 7500 9600 7725 9375 7725 9375 7500 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9375 7725 9600 7725 9600 7950 9375 7950 9375 7725 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9375 7950 9600 7950 9600 8175 9375 8175 9375 7950 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9375 8175 9600 8175 9600 8400 9375 8400 9375 8175 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9375 8400 9600 8400 9600 8625 9375 8625 9375 8400 +-6 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 1 1 2 + 0 0 1.00 60.00 120.00 + 0 0 1.00 60.00 120.00 + 1500 3825 1200 2550 +2 4 0 1 0 7 50 -1 -1 0.000 0 0 7 0 0 5 + 17025 10125 17025 9525 15750 9525 15750 10125 17025 10125 +2 1 0 1 0 7 50 -1 -1 3.000 0 0 -1 1 1 2 + 0 0 1.00 60.00 120.00 + 0 0 1.00 60.00 120.00 + 16050 9450 15525 8475 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 15825 11400 17175 11400 17175 11925 15825 11925 15825 11400 +2 1 0 1 0 7 50 -1 -1 3.000 0 0 -1 1 1 2 + 0 0 1.00 60.00 120.00 + 0 0 1.00 60.00 120.00 + 16350 10125 16350 11400 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 17550 10875 18900 10875 18900 11400 17550 11400 17550 10875 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 18375 9975 19725 9975 19725 10500 18375 10500 18375 9975 +2 1 0 1 0 7 50 -1 -1 3.000 0 0 -1 1 1 2 + 0 0 1.00 60.00 120.00 + 0 0 1.00 60.00 120.00 + 16725 10125 17850 10875 +2 1 0 1 0 7 50 -1 -1 3.000 0 0 -1 1 1 2 + 0 0 1.00 60.00 120.00 + 0 0 1.00 60.00 120.00 + 17025 9825 18375 10200 +2 1 0 1 14 7 50 -1 -1 3.000 0 0 -1 1 1 3 + 0 0 1.00 60.00 120.00 + 0 0 1.00 60.00 120.00 + 18975 9975 18075 8700 15900 7950 +2 2 0 1 0 7 50 -1 -1 3.000 0 0 -1 0 0 5 + 14100 6225 19950 6225 19950 12150 14100 12150 14100 6225 +2 1 0 1 0 7 50 -1 -1 3.000 0 0 -1 1 1 2 + 0 0 1.00 60.00 120.00 + 0 0 1.00 60.00 120.00 + 16575 9375 17850 7950 +2 2 0 1 0 7 50 -1 -1 3.000 0 0 -1 0 0 5 + 2100 10425 6150 10425 6150 14400 2100 14400 2100 10425 +2 2 0 1 0 7 50 -1 -1 3.000 0 0 -1 0 0 5 + 2325 10875 5925 10875 5925 13800 2325 13800 2325 10875 +2 2 0 1 0 7 50 -1 -1 3.000 0 0 -1 0 0 5 + 2400 10950 3975 10950 3975 11625 2400 11625 2400 10950 +2 4 0 1 0 7 50 -1 -1 0.000 0 0 7 0 0 5 + 5325 12675 5325 12075 4050 12075 4050 12675 5325 12675 +2 1 0 1 0 7 50 -1 -1 3.000 0 0 -1 1 0 2 + 0 0 1.00 60.00 120.00 + 3975 11250 4575 12075 +2 4 0 1 0 7 50 -1 -1 0.000 0 0 7 0 0 5 + 3300 3000 3300 225 225 225 225 3000 3300 3000 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 1 0 2 + 0 0 1.00 60.00 120.00 + 3675 7275 1800 7875 +2 4 0 1 0 7 50 -1 -1 0.000 0 0 7 0 0 5 + 2475 8775 2475 6675 225 6675 225 8775 2475 8775 +2 4 0 1 5 7 50 -1 -1 0.000 0 0 7 0 0 5 + 75 6525 75 9000 4950 9000 4950 6525 75 6525 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 1 0 2 + 0 0 1.00 60.00 120.00 + 2400 4200 5400 5400 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 1 1 2 + 0 0 1.00 60.00 120.00 + 0 0 1.00 60.00 120.00 + 1135 5476 1285 4426 +2 1 0 1 0 7 50 -1 -1 3.000 0 0 -1 1 1 2 + 0 0 1.00 60.00 120.00 + 0 0 1.00 60.00 120.00 + 2321 5402 1796 4427 +2 1 0 1 0 7 50 -1 -1 3.000 0 0 -1 1 1 2 + 0 0 1.00 60.00 120.00 + 0 0 1.00 60.00 120.00 + 6000 3075 1725 2100 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 1 1 2 + 0 0 1.00 60.00 120.00 + 0 0 1.00 60.00 120.00 + 1725 2250 7275 4425 +2 4 0 1 5 7 50 -1 -1 0.000 0 0 7 0 0 5 + 6300 525 6300 2175 3825 2175 3825 525 6300 525 +2 1 0 1 5 7 50 -1 -1 0.000 0 0 -1 0 0 2 + 3675 225 6000 2400 +2 1 0 1 5 7 50 -1 -1 0.000 0 0 -1 0 0 2 + 3825 2475 5775 300 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 7800 4050 12825 4050 12825 8925 7800 8925 7800 4050 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9225 6225 12450 6225 12450 8325 9225 8325 9225 6225 +2 2 0 1 4 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9225 6150 9675 6150 9675 8400 9225 8400 9225 6150 +3 2 0 1 0 7 50 -1 -1 3.000 0 1 1 3 + 0 0 1.00 60.00 120.00 + 0 0 1.00 60.00 120.00 + 4125 6675 3675 5250 2325 4425 + 0.000 -1.000 0.000 +4 0 0 50 -1 0 12 1.5708 4 150 390 8325 3975 run1\001 +4 0 0 50 -1 0 12 0.0000 4 150 900 15825 9750 rpc-server\001 +4 0 0 50 -1 0 12 0.0000 4 165 270 17475 9900 tcp\001 +4 0 0 50 -1 0 12 0.0000 4 120 315 18525 10200 test\001 +4 0 0 50 -1 0 12 0.0000 4 195 1065 14850 7275 megatest.db\001 +4 0 0 50 -1 0 12 0.0000 4 195 1305 17700 7875 mysql/postgres\001 +4 0 0 50 -1 0 12 0.0000 4 195 1875 14325 6600 mysql/postgres model\001 +4 0 0 50 -1 0 12 0.0000 4 195 4065 600 9300 Current state, no bypass - (if we switch to rpc?)\001 +4 0 0 50 -1 0 12 0.0000 4 195 1125 2175 10650 prev try RPC\001 +4 0 0 50 -1 0 12 0.0000 4 165 1095 2475 11100 rmt:get-tests\001 +4 0 0 50 -1 0 12 0.0000 4 195 2205 450 525 /tmp//??? /.db/*.db\001 +4 0 0 50 -1 0 12 0.0000 4 150 1110 8025 450 CHANGES:\001 +4 0 0 50 -1 0 12 0.0000 4 195 2145 8025 705 1. http -> rcp or nanomsg\001 +4 0 0 50 -1 0 12 0.0000 4 195 3330 8025 960 2. cache db moves from inmem to /tmp\001 +4 0 0 50 -1 0 12 0.0000 4 195 1410 2025 1875 megatest_ref.db\001 +4 0 0 50 -1 0 12 0.0000 4 150 1785 3675 375 Possible Future state\001 +4 0 0 50 -1 0 12 0.0000 4 195 1290 450 6900 Read-only user\001 +4 0 0 50 -1 0 12 0.0000 4 195 1755 675 8475 /tmp/.../megatest.db\001 +4 0 0 50 -1 0 12 0.0000 4 195 1065 3750 8025 megatest.db\001 +4 0 0 50 -1 0 12 0.0000 4 195 990 1650 2925 last_update\001 +4 0 0 50 -1 0 12 0.0000 4 195 330 1350 5100 http\001 +4 0 0 50 -1 0 12 0.0000 4 195 1065 750 2475 megatest.db\001 +4 0 0 50 -1 0 12 0.0000 4 150 945 9675 3750 Dashboard\001 ADDED docs/inprogress/megatest-architecture-proposed.fig Index: docs/inprogress/megatest-architecture-proposed.fig ================================================================== --- /dev/null +++ docs/inprogress/megatest-architecture-proposed.fig @@ -0,0 +1,504 @@ +#FIG 3.2 Produced by xfig version 3.2.5-alpha5 +Landscape +Center +Inches +Letter +100.00 +Single +-2 +1200 2 +# Copyright 2006-2017, Matthew Welland. +# +# This file is part of Megatest. +# +# Megatest is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# Megatest is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with Megatest. If not, see . +6 600 1350 1575 2400 +1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 1125 1500 450 150 1125 1500 1575 1650 +1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 1124 2177 450 150 1124 2177 1574 2327 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2 + 675 1575 675 2175 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2 + 1575 1500 1575 2175 +-6 +6 1875 825 2850 1875 +1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 2400 975 450 150 2400 975 2850 1125 +1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 2399 1652 450 150 2399 1652 2849 1802 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2 + 1950 1050 1950 1650 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2 + 2850 975 2850 1650 +-6 +6 3225 450 4200 1500 +1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 3750 600 450 150 3750 600 4200 750 +1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 3749 1277 450 150 3749 1277 4199 1427 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2 + 3300 675 3300 1275 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2 + 4200 600 4200 1275 +-6 +6 3075 2925 4050 3975 +1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 3600 3075 450 150 3600 3075 4050 3225 +1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 3599 3752 450 150 3599 3752 4049 3902 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2 + 3150 3150 3150 3750 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2 + 4050 3075 4050 3750 +-6 +6 7275 4050 12825 9675 +6 8175 4125 8400 8625 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8175 4125 8400 4125 8400 4350 8175 4350 8175 4125 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8175 4350 8400 4350 8400 4575 8175 4575 8175 4350 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8175 4575 8400 4575 8400 4800 8175 4800 8175 4575 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8175 4800 8400 4800 8400 5025 8175 5025 8175 4800 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8175 5025 8400 5025 8400 5250 8175 5250 8175 5025 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8175 5250 8400 5250 8400 5475 8175 5475 8175 5250 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8175 5475 8400 5475 8400 5700 8175 5700 8175 5475 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8175 5700 8400 5700 8400 5925 8175 5925 8175 5700 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8175 5925 8400 5925 8400 6150 8175 6150 8175 5925 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8175 6150 8400 6150 8400 6375 8175 6375 8175 6150 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8175 6375 8400 6375 8400 6600 8175 6600 8175 6375 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8175 6600 8400 6600 8400 6825 8175 6825 8175 6600 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8175 6825 8400 6825 8400 7050 8175 7050 8175 6825 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8175 7050 8400 7050 8400 7275 8175 7275 8175 7050 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8175 7275 8400 7275 8400 7500 8175 7500 8175 7275 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8175 7500 8400 7500 8400 7725 8175 7725 8175 7500 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8175 7725 8400 7725 8400 7950 8175 7950 8175 7725 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8175 7950 8400 7950 8400 8175 8175 8175 8175 7950 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8175 8175 8400 8175 8400 8400 8175 8400 8175 8175 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8175 8400 8400 8400 8400 8625 8175 8625 8175 8400 +-6 +6 8475 4125 8700 8625 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8475 4125 8700 4125 8700 4350 8475 4350 8475 4125 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8475 4350 8700 4350 8700 4575 8475 4575 8475 4350 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8475 4575 8700 4575 8700 4800 8475 4800 8475 4575 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8475 4800 8700 4800 8700 5025 8475 5025 8475 4800 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8475 5025 8700 5025 8700 5250 8475 5250 8475 5025 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8475 5250 8700 5250 8700 5475 8475 5475 8475 5250 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8475 5475 8700 5475 8700 5700 8475 5700 8475 5475 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8475 5700 8700 5700 8700 5925 8475 5925 8475 5700 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8475 5925 8700 5925 8700 6150 8475 6150 8475 5925 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8475 6150 8700 6150 8700 6375 8475 6375 8475 6150 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8475 6375 8700 6375 8700 6600 8475 6600 8475 6375 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8475 6600 8700 6600 8700 6825 8475 6825 8475 6600 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8475 6825 8700 6825 8700 7050 8475 7050 8475 6825 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8475 7050 8700 7050 8700 7275 8475 7275 8475 7050 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8475 7275 8700 7275 8700 7500 8475 7500 8475 7275 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8475 7500 8700 7500 8700 7725 8475 7725 8475 7500 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8475 7725 8700 7725 8700 7950 8475 7950 8475 7725 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8475 7950 8700 7950 8700 8175 8475 8175 8475 7950 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8475 8175 8700 8175 8700 8400 8475 8400 8475 8175 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8475 8400 8700 8400 8700 8625 8475 8625 8475 8400 +-6 +6 8775 4125 9000 8625 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8775 4125 9000 4125 9000 4350 8775 4350 8775 4125 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8775 4350 9000 4350 9000 4575 8775 4575 8775 4350 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8775 4575 9000 4575 9000 4800 8775 4800 8775 4575 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8775 4800 9000 4800 9000 5025 8775 5025 8775 4800 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8775 5025 9000 5025 9000 5250 8775 5250 8775 5025 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8775 5250 9000 5250 9000 5475 8775 5475 8775 5250 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8775 5475 9000 5475 9000 5700 8775 5700 8775 5475 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8775 5700 9000 5700 9000 5925 8775 5925 8775 5700 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8775 5925 9000 5925 9000 6150 8775 6150 8775 5925 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8775 6150 9000 6150 9000 6375 8775 6375 8775 6150 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8775 6375 9000 6375 9000 6600 8775 6600 8775 6375 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8775 6600 9000 6600 9000 6825 8775 6825 8775 6600 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8775 6825 9000 6825 9000 7050 8775 7050 8775 6825 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8775 7050 9000 7050 9000 7275 8775 7275 8775 7050 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8775 7275 9000 7275 9000 7500 8775 7500 8775 7275 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8775 7500 9000 7500 9000 7725 8775 7725 8775 7500 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8775 7725 9000 7725 9000 7950 8775 7950 8775 7725 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8775 7950 9000 7950 9000 8175 8775 8175 8775 7950 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8775 8175 9000 8175 9000 8400 8775 8400 8775 8175 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8775 8400 9000 8400 9000 8625 8775 8625 8775 8400 +-6 +6 9075 4125 9300 8625 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9075 4125 9300 4125 9300 4350 9075 4350 9075 4125 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9075 4350 9300 4350 9300 4575 9075 4575 9075 4350 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9075 4575 9300 4575 9300 4800 9075 4800 9075 4575 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9075 4800 9300 4800 9300 5025 9075 5025 9075 4800 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9075 5025 9300 5025 9300 5250 9075 5250 9075 5025 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9075 5250 9300 5250 9300 5475 9075 5475 9075 5250 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9075 5475 9300 5475 9300 5700 9075 5700 9075 5475 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9075 5700 9300 5700 9300 5925 9075 5925 9075 5700 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9075 5925 9300 5925 9300 6150 9075 6150 9075 5925 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9075 6150 9300 6150 9300 6375 9075 6375 9075 6150 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9075 6375 9300 6375 9300 6600 9075 6600 9075 6375 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9075 6600 9300 6600 9300 6825 9075 6825 9075 6600 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9075 6825 9300 6825 9300 7050 9075 7050 9075 6825 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9075 7050 9300 7050 9300 7275 9075 7275 9075 7050 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9075 7275 9300 7275 9300 7500 9075 7500 9075 7275 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9075 7500 9300 7500 9300 7725 9075 7725 9075 7500 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9075 7725 9300 7725 9300 7950 9075 7950 9075 7725 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9075 7950 9300 7950 9300 8175 9075 8175 9075 7950 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9075 8175 9300 8175 9300 8400 9075 8400 9075 8175 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9075 8400 9300 8400 9300 8625 9075 8625 9075 8400 +-6 +6 9375 4125 9600 8625 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9375 4125 9600 4125 9600 4350 9375 4350 9375 4125 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9375 4350 9600 4350 9600 4575 9375 4575 9375 4350 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9375 4575 9600 4575 9600 4800 9375 4800 9375 4575 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9375 4800 9600 4800 9600 5025 9375 5025 9375 4800 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9375 5025 9600 5025 9600 5250 9375 5250 9375 5025 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9375 5250 9600 5250 9600 5475 9375 5475 9375 5250 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9375 5475 9600 5475 9600 5700 9375 5700 9375 5475 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9375 5700 9600 5700 9600 5925 9375 5925 9375 5700 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9375 5925 9600 5925 9600 6150 9375 6150 9375 5925 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9375 6150 9600 6150 9600 6375 9375 6375 9375 6150 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9375 6375 9600 6375 9600 6600 9375 6600 9375 6375 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9375 6600 9600 6600 9600 6825 9375 6825 9375 6600 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9375 6825 9600 6825 9600 7050 9375 7050 9375 6825 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9375 7050 9600 7050 9600 7275 9375 7275 9375 7050 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9375 7275 9600 7275 9600 7500 9375 7500 9375 7275 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9375 7500 9600 7500 9600 7725 9375 7725 9375 7500 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9375 7725 9600 7725 9600 7950 9375 7950 9375 7725 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9375 7950 9600 7950 9600 8175 9375 8175 9375 7950 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9375 8175 9600 8175 9600 8400 9375 8400 9375 8175 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9375 8400 9600 8400 9600 8625 9375 8625 9375 8400 +-6 +# Dimension line: 1-1/16 in +6 7875 9375 9150 9675 +# main dimension line +2 1 0 1 0 7 50 -1 -1 4.000 0 0 -1 1 1 2 + 1 1 1.00 60.00 120.00 + 1 1 1.00 60.00 120.00 + 7875 9525 9150 9525 +# text box +2 3 0 1 4 7 49 -1 20 0.000 0 0 -1 0 0 5 + 8085 9375 8085 9675 8939 9675 8939 9375 8085 9375 +# tick +2 1 0 1 0 7 50 -1 -1 4.000 0 0 -1 0 0 2 + 7875 9375 7875 9675 +# tick +2 1 0 1 0 7 50 -1 -1 4.000 0 0 -1 0 0 2 + 9150 9375 9150 9675 +4 1 0 48 -1 0 12 -0.0000 4 180 735 8512 9585 1-1/16 in\001 +-6 +# Dimension line: 1-11/16 in +6 7425 4125 7725 6150 +# main dimension line +2 1 0 1 0 7 50 -1 -1 4.000 0 0 -1 1 1 2 + 1 1 1.00 60.00 120.00 + 1 1 1.00 60.00 120.00 + 7575 4125 7575 6150 +# text box +2 3 0 1 4 7 49 -1 20 0.000 0 0 -1 0 0 5 + 7425 5617 7725 5617 7725 4657 7425 4657 7425 5617 +# tick +2 1 0 1 0 7 50 -1 -1 4.000 0 0 -1 0 0 2 + 7425 6150 7725 6150 +# tick +2 1 0 1 0 7 50 -1 -1 4.000 0 0 -1 0 0 2 + 7425 4125 7725 4125 +4 1 0 48 -1 0 12 1.5708 4 180 840 7635 5137 1-11/16 in\001 +-6 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 7800 4050 12825 4050 12825 8925 7800 8925 7800 4050 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9225 6225 12450 6225 12450 8325 9225 8325 9225 6225 +2 2 0 1 4 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9225 6150 9675 6150 9675 8400 9225 8400 9225 6150 +4 0 0 50 -1 0 12 0.0000 4 150 150 8475 9300 X\001 +4 0 0 50 -1 0 12 0.0000 4 150 135 7275 6975 Y\001 +-6 +6 14100 150 19950 6075 +6 14850 1350 15825 2400 +1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 15375 1500 450 150 15375 1500 15825 1650 +1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 15374 2177 450 150 15374 2177 15824 2327 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2 + 14925 1575 14925 2175 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2 + 15825 1500 15825 2175 +-6 +2 4 0 1 0 7 50 -1 -1 0.000 0 0 7 0 0 5 + 17025 4050 17025 3450 15750 3450 15750 4050 17025 4050 +2 1 0 1 0 7 50 -1 -1 3.000 0 0 -1 1 1 2 + 0 0 1.00 60.00 120.00 + 0 0 1.00 60.00 120.00 + 16050 3375 15525 2400 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 15825 5325 17175 5325 17175 5850 15825 5850 15825 5325 +2 1 0 1 0 7 50 -1 -1 3.000 0 0 -1 1 1 2 + 0 0 1.00 60.00 120.00 + 0 0 1.00 60.00 120.00 + 16350 4050 16350 5325 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 17550 4800 18900 4800 18900 5325 17550 5325 17550 4800 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 18375 3900 19725 3900 19725 4425 18375 4425 18375 3900 +2 1 0 1 0 7 50 -1 -1 3.000 0 0 -1 1 1 2 + 0 0 1.00 60.00 120.00 + 0 0 1.00 60.00 120.00 + 16725 4050 17850 4800 +2 1 0 1 0 7 50 -1 -1 3.000 0 0 -1 1 1 2 + 0 0 1.00 60.00 120.00 + 0 0 1.00 60.00 120.00 + 17025 3750 18375 4125 +2 1 0 1 14 7 50 -1 -1 3.000 0 0 -1 1 1 3 + 0 0 1.00 60.00 120.00 + 0 0 1.00 60.00 120.00 + 18975 3900 18075 2625 15900 1875 +2 2 0 1 0 7 50 -1 -1 3.000 0 0 -1 0 0 5 + 14100 150 19950 150 19950 6075 14100 6075 14100 150 +4 0 0 50 -1 0 12 0.0000 4 150 900 15825 3675 rpc-server\001 +4 0 0 50 -1 0 12 0.0000 4 165 270 17475 3825 tcp\001 +4 0 0 50 -1 0 12 0.0000 4 120 315 18525 4125 test\001 +4 0 0 50 -1 0 12 0.0000 4 195 1065 14850 1200 megatest.db\001 +4 0 0 50 -1 0 12 0.0000 4 150 1020 14325 525 basic model\001 +-6 +6 14850 7425 15825 8475 +1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 15375 7575 450 150 15375 7575 15825 7725 +1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 15374 8252 450 150 15374 8252 15824 8402 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2 + 14925 7650 14925 8250 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2 + 15825 7575 15825 8250 +-6 +6 17775 6675 18750 7725 +1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 18300 6825 450 150 18300 6825 18750 6975 +1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 18299 7502 450 150 18299 7502 18749 7652 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2 + 17850 6900 17850 7500 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2 + 18750 6825 18750 7500 +-6 +6 4875 6075 5850 7125 +1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 5400 6225 450 150 5400 6225 5850 6375 +1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 5399 6902 450 150 5399 6902 5849 7052 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2 + 4950 6300 4950 6900 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2 + 5850 6225 5850 6900 +-6 +6 5400 7425 7350 8925 +6 5475 7650 6450 8700 +1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 6000 7800 450 150 6000 7800 6450 7950 +1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 5999 8477 450 150 5999 8477 6449 8627 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2 + 5550 7875 5550 8475 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2 + 6450 7800 6450 8475 +-6 +4 0 0 50 -1 0 12 0.0000 4 195 1905 5400 8850 pointers to the servers\001 +4 0 0 50 -1 0 12 0.0000 4 150 930 5550 7575 monitor.db\001 +-6 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 1 1 2 + 0 0 1.00 60.00 120.00 + 0 0 1.00 60.00 120.00 + 1725 5025 1275 2475 +2 4 0 1 0 7 50 -1 -1 0.000 0 0 7 0 0 5 + 5550 4500 5550 225 225 225 225 4500 5550 4500 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 1 1 2 + 0 0 1.00 60.00 120.00 + 0 0 1.00 60.00 120.00 + 1875 7725 1875 5775 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 1 1 2 + 0 0 1.00 60.00 120.00 + 0 0 1.00 60.00 120.00 + 2775 5400 7125 5700 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 1425 7725 2775 7725 2775 8250 1425 8250 1425 7725 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 3375 7725 4725 7725 4725 8250 3375 8250 3375 7725 +2 1 0 1 0 7 50 -1 -1 3.000 0 0 -1 1 1 2 + 0 0 1.00 60.00 120.00 + 0 0 1.00 60.00 120.00 + 3675 7725 2175 5775 +2 4 0 1 0 7 50 -1 -1 0.000 0 0 7 0 0 5 + 2775 5700 2775 5100 1500 5100 1500 5700 2775 5700 +2 1 0 1 0 7 50 -1 -1 3.000 0 0 -1 1 1 2 + 0 0 1.00 60.00 120.00 + 0 0 1.00 60.00 120.00 + 6600 3300 2925 5025 +2 4 0 1 0 7 50 -1 -1 0.000 0 0 7 0 0 5 + 17025 10125 17025 9525 15750 9525 15750 10125 17025 10125 +2 1 0 1 0 7 50 -1 -1 3.000 0 0 -1 1 1 2 + 0 0 1.00 60.00 120.00 + 0 0 1.00 60.00 120.00 + 16050 9450 15525 8475 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 15825 11400 17175 11400 17175 11925 15825 11925 15825 11400 +2 1 0 1 0 7 50 -1 -1 3.000 0 0 -1 1 1 2 + 0 0 1.00 60.00 120.00 + 0 0 1.00 60.00 120.00 + 16350 10125 16350 11400 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 17550 10875 18900 10875 18900 11400 17550 11400 17550 10875 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 18375 9975 19725 9975 19725 10500 18375 10500 18375 9975 +2 1 0 1 0 7 50 -1 -1 3.000 0 0 -1 1 1 2 + 0 0 1.00 60.00 120.00 + 0 0 1.00 60.00 120.00 + 16725 10125 17850 10875 +2 1 0 1 0 7 50 -1 -1 3.000 0 0 -1 1 1 2 + 0 0 1.00 60.00 120.00 + 0 0 1.00 60.00 120.00 + 17025 9825 18375 10200 +2 1 0 1 14 7 50 -1 -1 3.000 0 0 -1 1 1 3 + 0 0 1.00 60.00 120.00 + 0 0 1.00 60.00 120.00 + 18975 9975 18075 8700 15900 7950 +2 2 0 1 0 7 50 -1 -1 3.000 0 0 -1 0 0 5 + 14100 6225 19950 6225 19950 12150 14100 12150 14100 6225 +2 1 0 1 0 7 50 -1 -1 3.000 0 0 -1 1 1 2 + 0 0 1.00 60.00 120.00 + 0 0 1.00 60.00 120.00 + 16575 9375 17850 7950 +2 2 0 1 0 7 50 -1 -1 3.000 0 0 -1 0 0 5 + 2100 10425 6150 10425 6150 14400 2100 14400 2100 10425 +2 2 0 1 0 7 50 -1 -1 3.000 0 0 -1 0 0 5 + 2325 10875 5925 10875 5925 13800 2325 13800 2325 10875 +2 2 0 1 0 7 50 -1 -1 3.000 0 0 -1 0 0 5 + 2400 10950 3975 10950 3975 11625 2400 11625 2400 10950 +2 4 0 1 0 7 50 -1 -1 0.000 0 0 7 0 0 5 + 5325 12675 5325 12075 4050 12075 4050 12675 5325 12675 +2 1 0 1 0 7 50 -1 -1 3.000 0 0 -1 1 0 2 + 0 0 1.00 60.00 120.00 + 3975 11250 4575 12075 +2 1 0 1 0 7 50 -1 -1 3.000 0 0 -1 1 1 2 + 0 0 1.00 60.00 120.00 + 0 0 1.00 60.00 120.00 + 2175 5025 3075 3750 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 6150 2700 7500 2700 7500 3225 6150 3225 6150 2700 +2 1 0 1 0 7 50 -1 -1 3.000 0 0 -1 1 1 2 + 0 0 1.00 60.00 120.00 + 0 0 1.00 60.00 120.00 + 4800 6375 2850 5550 +4 0 0 50 -1 0 12 0.0000 4 195 990 1800 2625 last_update\001 +4 0 0 50 -1 0 12 0.0000 4 150 690 3150 4125 main.db\001 +4 0 0 50 -1 0 12 0.0000 4 195 990 4200 3600 last_update\001 +4 0 0 50 -1 0 12 0.0000 4 195 330 1950 6825 http\001 +4 0 0 50 -1 0 12 0.0000 4 180 870 1575 7950 run1/test1\001 +4 0 0 50 -1 0 12 0.0000 4 150 720 1650 5400 server-1\001 +4 0 0 50 -1 0 12 0.0000 4 150 375 2175 2025 2.db\001 +4 0 0 50 -1 0 12 0.0000 4 150 375 750 2550 1.db\001 +4 0 0 50 -1 0 12 0.0000 4 180 870 3450 7950 run1/test2\001 +4 0 0 50 -1 0 12 0.0000 4 150 1110 9675 3750 Dashboardm\001 +4 0 0 50 -1 0 12 1.5708 4 150 390 8325 3975 run1\001 +4 0 0 50 -1 0 12 0.0000 4 150 900 15825 9750 rpc-server\001 +4 0 0 50 -1 0 12 0.0000 4 165 270 17475 9900 tcp\001 +4 0 0 50 -1 0 12 0.0000 4 120 315 18525 10200 test\001 +4 0 0 50 -1 0 12 0.0000 4 195 1065 14850 7275 megatest.db\001 +4 0 0 50 -1 0 12 0.0000 4 195 1305 17700 7875 mysql/postgres\001 +4 0 0 50 -1 0 12 0.0000 4 195 1875 14325 6600 mysql/postgres model\001 +4 0 0 50 -1 0 12 0.0000 4 195 4065 600 9300 Current state, no bypass - (if we switch to rpc?)\001 +4 0 0 50 -1 0 12 0.0000 4 195 1125 2175 10650 prev try RPC\001 +4 0 0 50 -1 0 12 0.0000 4 165 1095 2475 11100 rmt:get-tests\001 +4 0 0 50 -1 0 12 0.0000 4 195 2205 450 525 /tmp//??? /.db/*.db\001 +4 0 0 50 -1 0 12 0.0000 4 180 870 6225 2925 run2/test1\001 +4 0 0 50 -1 0 12 0.0000 4 195 1065 4800 7350 megatest.db\001 +4 0 0 50 -1 0 12 0.0000 4 150 1785 600 8775 Possible Future state\001 +4 0 0 50 -1 0 12 0.0000 4 150 1110 8025 450 CHANGES:\001 +4 0 0 50 -1 0 12 0.0000 4 195 2145 8025 705 1. http -> rcp or nanomsg\001 +4 0 0 50 -1 0 12 0.0000 4 195 3330 8025 960 2. cache db moves from inmem to /tmp\001 ADDED docs/inprogress/megatest-architecture.fig Index: docs/inprogress/megatest-architecture.fig ================================================================== --- /dev/null +++ docs/inprogress/megatest-architecture.fig @@ -0,0 +1,544 @@ +#FIG 3.2 Produced by xfig version 3.2.5-alpha5 +Landscape +Center +Inches +Letter +100.00 +Single +-2 +1200 2 +# Copyright 2006-2017, Matthew Welland. +# +# This file is part of Megatest. +# +# Megatest is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# Megatest is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with Megatest. If not, see . +6 600 1350 1575 2400 +1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 1125 1500 450 150 1125 1500 1575 1650 +1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 1124 2177 450 150 1124 2177 1574 2327 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2 + 675 1575 675 2175 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2 + 1575 1500 1575 2175 +-6 +6 1875 825 2850 1875 +1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 2400 975 450 150 2400 975 2850 1125 +1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 2399 1652 450 150 2399 1652 2849 1802 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2 + 1950 1050 1950 1650 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2 + 2850 975 2850 1650 +-6 +6 3225 450 4200 1500 +1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 3750 600 450 150 3750 600 4200 750 +1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 3749 1277 450 150 3749 1277 4199 1427 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2 + 3300 675 3300 1275 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2 + 4200 600 4200 1275 +-6 +6 3075 2925 4050 3975 +1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 3600 3075 450 150 3600 3075 4050 3225 +1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 3599 3752 450 150 3599 3752 4049 3902 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2 + 3150 3150 3150 3750 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2 + 4050 3075 4050 3750 +-6 +6 7275 4050 12825 9675 +6 8175 4125 8400 8625 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8175 4125 8400 4125 8400 4350 8175 4350 8175 4125 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8175 4350 8400 4350 8400 4575 8175 4575 8175 4350 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8175 4575 8400 4575 8400 4800 8175 4800 8175 4575 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8175 4800 8400 4800 8400 5025 8175 5025 8175 4800 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8175 5025 8400 5025 8400 5250 8175 5250 8175 5025 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8175 5250 8400 5250 8400 5475 8175 5475 8175 5250 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8175 5475 8400 5475 8400 5700 8175 5700 8175 5475 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8175 5700 8400 5700 8400 5925 8175 5925 8175 5700 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8175 5925 8400 5925 8400 6150 8175 6150 8175 5925 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8175 6150 8400 6150 8400 6375 8175 6375 8175 6150 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8175 6375 8400 6375 8400 6600 8175 6600 8175 6375 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8175 6600 8400 6600 8400 6825 8175 6825 8175 6600 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8175 6825 8400 6825 8400 7050 8175 7050 8175 6825 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8175 7050 8400 7050 8400 7275 8175 7275 8175 7050 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8175 7275 8400 7275 8400 7500 8175 7500 8175 7275 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8175 7500 8400 7500 8400 7725 8175 7725 8175 7500 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8175 7725 8400 7725 8400 7950 8175 7950 8175 7725 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8175 7950 8400 7950 8400 8175 8175 8175 8175 7950 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8175 8175 8400 8175 8400 8400 8175 8400 8175 8175 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8175 8400 8400 8400 8400 8625 8175 8625 8175 8400 +-6 +6 8475 4125 8700 8625 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8475 4125 8700 4125 8700 4350 8475 4350 8475 4125 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8475 4350 8700 4350 8700 4575 8475 4575 8475 4350 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8475 4575 8700 4575 8700 4800 8475 4800 8475 4575 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8475 4800 8700 4800 8700 5025 8475 5025 8475 4800 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8475 5025 8700 5025 8700 5250 8475 5250 8475 5025 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8475 5250 8700 5250 8700 5475 8475 5475 8475 5250 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8475 5475 8700 5475 8700 5700 8475 5700 8475 5475 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8475 5700 8700 5700 8700 5925 8475 5925 8475 5700 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8475 5925 8700 5925 8700 6150 8475 6150 8475 5925 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8475 6150 8700 6150 8700 6375 8475 6375 8475 6150 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8475 6375 8700 6375 8700 6600 8475 6600 8475 6375 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8475 6600 8700 6600 8700 6825 8475 6825 8475 6600 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8475 6825 8700 6825 8700 7050 8475 7050 8475 6825 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8475 7050 8700 7050 8700 7275 8475 7275 8475 7050 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8475 7275 8700 7275 8700 7500 8475 7500 8475 7275 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8475 7500 8700 7500 8700 7725 8475 7725 8475 7500 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8475 7725 8700 7725 8700 7950 8475 7950 8475 7725 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8475 7950 8700 7950 8700 8175 8475 8175 8475 7950 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8475 8175 8700 8175 8700 8400 8475 8400 8475 8175 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8475 8400 8700 8400 8700 8625 8475 8625 8475 8400 +-6 +6 8775 4125 9000 8625 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8775 4125 9000 4125 9000 4350 8775 4350 8775 4125 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8775 4350 9000 4350 9000 4575 8775 4575 8775 4350 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8775 4575 9000 4575 9000 4800 8775 4800 8775 4575 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8775 4800 9000 4800 9000 5025 8775 5025 8775 4800 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8775 5025 9000 5025 9000 5250 8775 5250 8775 5025 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8775 5250 9000 5250 9000 5475 8775 5475 8775 5250 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8775 5475 9000 5475 9000 5700 8775 5700 8775 5475 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8775 5700 9000 5700 9000 5925 8775 5925 8775 5700 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8775 5925 9000 5925 9000 6150 8775 6150 8775 5925 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8775 6150 9000 6150 9000 6375 8775 6375 8775 6150 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8775 6375 9000 6375 9000 6600 8775 6600 8775 6375 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8775 6600 9000 6600 9000 6825 8775 6825 8775 6600 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8775 6825 9000 6825 9000 7050 8775 7050 8775 6825 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8775 7050 9000 7050 9000 7275 8775 7275 8775 7050 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8775 7275 9000 7275 9000 7500 8775 7500 8775 7275 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8775 7500 9000 7500 9000 7725 8775 7725 8775 7500 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8775 7725 9000 7725 9000 7950 8775 7950 8775 7725 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8775 7950 9000 7950 9000 8175 8775 8175 8775 7950 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8775 8175 9000 8175 9000 8400 8775 8400 8775 8175 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8775 8400 9000 8400 9000 8625 8775 8625 8775 8400 +-6 +6 9075 4125 9300 8625 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9075 4125 9300 4125 9300 4350 9075 4350 9075 4125 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9075 4350 9300 4350 9300 4575 9075 4575 9075 4350 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9075 4575 9300 4575 9300 4800 9075 4800 9075 4575 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9075 4800 9300 4800 9300 5025 9075 5025 9075 4800 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9075 5025 9300 5025 9300 5250 9075 5250 9075 5025 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9075 5250 9300 5250 9300 5475 9075 5475 9075 5250 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9075 5475 9300 5475 9300 5700 9075 5700 9075 5475 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9075 5700 9300 5700 9300 5925 9075 5925 9075 5700 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9075 5925 9300 5925 9300 6150 9075 6150 9075 5925 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9075 6150 9300 6150 9300 6375 9075 6375 9075 6150 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9075 6375 9300 6375 9300 6600 9075 6600 9075 6375 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9075 6600 9300 6600 9300 6825 9075 6825 9075 6600 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9075 6825 9300 6825 9300 7050 9075 7050 9075 6825 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9075 7050 9300 7050 9300 7275 9075 7275 9075 7050 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9075 7275 9300 7275 9300 7500 9075 7500 9075 7275 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9075 7500 9300 7500 9300 7725 9075 7725 9075 7500 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9075 7725 9300 7725 9300 7950 9075 7950 9075 7725 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9075 7950 9300 7950 9300 8175 9075 8175 9075 7950 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9075 8175 9300 8175 9300 8400 9075 8400 9075 8175 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9075 8400 9300 8400 9300 8625 9075 8625 9075 8400 +-6 +6 9375 4125 9600 8625 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9375 4125 9600 4125 9600 4350 9375 4350 9375 4125 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9375 4350 9600 4350 9600 4575 9375 4575 9375 4350 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9375 4575 9600 4575 9600 4800 9375 4800 9375 4575 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9375 4800 9600 4800 9600 5025 9375 5025 9375 4800 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9375 5025 9600 5025 9600 5250 9375 5250 9375 5025 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9375 5250 9600 5250 9600 5475 9375 5475 9375 5250 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9375 5475 9600 5475 9600 5700 9375 5700 9375 5475 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9375 5700 9600 5700 9600 5925 9375 5925 9375 5700 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9375 5925 9600 5925 9600 6150 9375 6150 9375 5925 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9375 6150 9600 6150 9600 6375 9375 6375 9375 6150 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9375 6375 9600 6375 9600 6600 9375 6600 9375 6375 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9375 6600 9600 6600 9600 6825 9375 6825 9375 6600 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9375 6825 9600 6825 9600 7050 9375 7050 9375 6825 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9375 7050 9600 7050 9600 7275 9375 7275 9375 7050 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9375 7275 9600 7275 9600 7500 9375 7500 9375 7275 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9375 7500 9600 7500 9600 7725 9375 7725 9375 7500 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9375 7725 9600 7725 9600 7950 9375 7950 9375 7725 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9375 7950 9600 7950 9600 8175 9375 8175 9375 7950 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9375 8175 9600 8175 9600 8400 9375 8400 9375 8175 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9375 8400 9600 8400 9600 8625 9375 8625 9375 8400 +-6 +# Dimension line: 1-1/16 in +6 7875 9375 9150 9675 +# main dimension line +2 1 0 1 0 7 50 -1 -1 4.000 0 0 -1 1 1 2 + 1 1 1.00 60.00 120.00 + 1 1 1.00 60.00 120.00 + 7875 9525 9150 9525 +# text box +2 3 0 1 4 7 49 -1 20 0.000 0 0 -1 0 0 5 + 8085 9375 8085 9675 8939 9675 8939 9375 8085 9375 +# tick +2 1 0 1 0 7 50 -1 -1 4.000 0 0 -1 0 0 2 + 7875 9375 7875 9675 +# tick +2 1 0 1 0 7 50 -1 -1 4.000 0 0 -1 0 0 2 + 9150 9375 9150 9675 +4 1 0 48 -1 0 12 -0.0000 4 180 735 8512 9585 1-1/16 in\001 +-6 +# Dimension line: 1-11/16 in +6 7425 4125 7725 6150 +# main dimension line +2 1 0 1 0 7 50 -1 -1 4.000 0 0 -1 1 1 2 + 1 1 1.00 60.00 120.00 + 1 1 1.00 60.00 120.00 + 7575 4125 7575 6150 +# text box +2 3 0 1 4 7 49 -1 20 0.000 0 0 -1 0 0 5 + 7425 5617 7725 5617 7725 4657 7425 4657 7425 5617 +# tick +2 1 0 1 0 7 50 -1 -1 4.000 0 0 -1 0 0 2 + 7425 6150 7725 6150 +# tick +2 1 0 1 0 7 50 -1 -1 4.000 0 0 -1 0 0 2 + 7425 4125 7725 4125 +4 1 0 48 -1 0 12 1.5708 4 180 840 7635 5137 1-11/16 in\001 +-6 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 7800 4050 12825 4050 12825 8925 7800 8925 7800 4050 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9225 6225 12450 6225 12450 8325 9225 8325 9225 6225 +2 2 0 1 4 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9225 6150 9675 6150 9675 8400 9225 8400 9225 6150 +4 0 0 50 -1 0 12 0.0000 4 150 150 8475 9300 X\001 +4 0 0 50 -1 0 12 0.0000 4 150 135 7275 6975 Y\001 +-6 +6 975 5100 1500 5700 +1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 1258 5186 242 86 1258 5186 1500 5271 +1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 1257 5573 242 86 1257 5573 1499 5658 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2 + 1015 5229 1015 5571 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2 + 1500 5186 1500 5571 +-6 +6 3000 6075 3525 6675 +1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 3283 6161 242 86 3283 6161 3525 6246 +1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 3282 6548 242 86 3282 6548 3524 6633 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2 + 3040 6204 3040 6546 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2 + 3525 6161 3525 6546 +-6 +6 7575 2625 8100 3225 +1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 7858 2711 242 86 7858 2711 8100 2796 +1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 7857 3098 242 86 7857 3098 8099 3183 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2 + 7615 2754 7615 3096 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2 + 8100 2711 8100 3096 +-6 +6 9525 450 10500 1500 +1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 10050 600 450 150 10050 600 10500 750 +1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 10049 1277 450 150 10049 1277 10499 1427 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2 + 9600 675 9600 1275 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2 + 10500 600 10500 1275 +-6 +6 14100 150 19950 6075 +6 14850 1350 15825 2400 +1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 15375 1500 450 150 15375 1500 15825 1650 +1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 15374 2177 450 150 15374 2177 15824 2327 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2 + 14925 1575 14925 2175 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2 + 15825 1500 15825 2175 +-6 +2 4 0 1 0 7 50 -1 -1 0.000 0 0 7 0 0 5 + 17025 4050 17025 3450 15750 3450 15750 4050 17025 4050 +2 1 0 1 0 7 50 -1 -1 3.000 0 0 -1 1 1 2 + 0 0 1.00 60.00 120.00 + 0 0 1.00 60.00 120.00 + 16050 3375 15525 2400 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 15825 5325 17175 5325 17175 5850 15825 5850 15825 5325 +2 1 0 1 0 7 50 -1 -1 3.000 0 0 -1 1 1 2 + 0 0 1.00 60.00 120.00 + 0 0 1.00 60.00 120.00 + 16350 4050 16350 5325 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 17550 4800 18900 4800 18900 5325 17550 5325 17550 4800 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 18375 3900 19725 3900 19725 4425 18375 4425 18375 3900 +2 1 0 1 0 7 50 -1 -1 3.000 0 0 -1 1 1 2 + 0 0 1.00 60.00 120.00 + 0 0 1.00 60.00 120.00 + 16725 4050 17850 4800 +2 1 0 1 0 7 50 -1 -1 3.000 0 0 -1 1 1 2 + 0 0 1.00 60.00 120.00 + 0 0 1.00 60.00 120.00 + 17025 3750 18375 4125 +2 1 0 1 14 7 50 -1 -1 3.000 0 0 -1 1 1 3 + 0 0 1.00 60.00 120.00 + 0 0 1.00 60.00 120.00 + 18975 3900 18075 2625 15900 1875 +2 2 0 1 0 7 50 -1 -1 3.000 0 0 -1 0 0 5 + 14100 150 19950 150 19950 6075 14100 6075 14100 150 +4 0 0 50 -1 0 12 0.0000 4 150 900 15825 3675 rpc-server\001 +4 0 0 50 -1 0 12 0.0000 4 165 270 17475 3825 tcp\001 +4 0 0 50 -1 0 12 0.0000 4 120 315 18525 4125 test\001 +4 0 0 50 -1 0 12 0.0000 4 195 1065 14850 1200 megatest.db\001 +4 0 0 50 -1 0 12 0.0000 4 150 1020 14325 525 basic model\001 +-6 +6 14850 7425 15825 8475 +1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 15375 7575 450 150 15375 7575 15825 7725 +1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 15374 8252 450 150 15374 8252 15824 8402 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2 + 14925 7650 14925 8250 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2 + 15825 7575 15825 8250 +-6 +6 17775 6675 18750 7725 +1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 18300 6825 450 150 18300 6825 18750 6975 +1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 18299 7502 450 150 18299 7502 18749 7652 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2 + 17850 6900 17850 7500 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2 + 18750 6825 18750 7500 +-6 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 1 1 2 + 0 0 1.00 60.00 120.00 + 0 0 1.00 60.00 120.00 + 1725 5025 1275 2475 +2 4 0 1 0 7 50 -1 -1 0.000 0 0 7 0 0 5 + 5550 4500 5550 225 225 225 225 4500 5550 4500 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 1 1 2 + 0 0 1.00 60.00 120.00 + 0 0 1.00 60.00 120.00 + 1875 7725 1875 5775 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 1 1 2 + 0 0 1.00 60.00 120.00 + 0 0 1.00 60.00 120.00 + 2775 5400 7125 5700 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 1 1 2 + 0 0 1.00 60.00 120.00 + 0 0 1.00 60.00 120.00 + 2400 7725 3900 6675 +2 1 0 1 0 7 50 -1 -1 3.000 0 0 -1 1 1 2 + 0 0 1.00 60.00 120.00 + 0 0 1.00 60.00 120.00 + 4275 6075 3825 4200 +2 1 0 1 0 7 50 -1 -1 3.000 0 0 -1 1 1 2 + 0 0 1.00 60.00 120.00 + 0 0 1.00 60.00 120.00 + 7125 5850 4800 6300 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 1425 7725 2775 7725 2775 8250 1425 8250 1425 7725 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 3375 7725 4725 7725 4725 8250 3375 8250 3375 7725 +2 1 0 1 0 7 50 -1 -1 3.000 0 0 -1 1 1 2 + 0 0 1.00 60.00 120.00 + 0 0 1.00 60.00 120.00 + 3675 7725 2175 5775 +2 1 0 1 0 7 50 -1 -1 3.000 0 0 -1 1 1 2 + 0 0 1.00 60.00 120.00 + 0 0 1.00 60.00 120.00 + 3975 7725 3975 6750 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 7125 825 8475 825 8475 1350 7125 1350 7125 825 +2 4 0 1 0 7 50 -1 -1 0.000 0 0 7 0 0 5 + 2775 5700 2775 5100 1500 5100 1500 5700 2775 5700 +2 4 0 1 0 7 50 -1 -1 0.000 0 0 7 0 0 5 + 4800 6675 4800 6075 3525 6075 3525 6675 4800 6675 +2 4 0 1 0 7 50 -1 -1 0.000 0 0 7 0 0 5 + 7575 3225 7575 2625 6300 2625 6300 3225 7575 3225 +2 1 0 1 0 7 50 -1 -1 3.000 0 0 -1 1 1 2 + 0 0 1.00 60.00 120.00 + 0 0 1.00 60.00 120.00 + 7650 1425 6975 2625 +2 1 0 1 0 7 50 -1 -1 3.000 0 0 -1 1 1 2 + 0 0 1.00 60.00 120.00 + 0 0 1.00 60.00 120.00 + 6300 2925 2850 1725 +2 1 0 1 0 7 50 -1 -1 3.000 0 0 -1 1 1 2 + 0 0 1.00 60.00 120.00 + 0 0 1.00 60.00 120.00 + 6975 3300 7725 3900 +2 1 0 1 0 7 50 -1 -1 3.000 0 0 -1 1 1 4 + 0 0 1.00 60.00 120.00 + 0 0 1.00 60.00 120.00 + 7200 1350 5925 2550 5925 4875 4650 6000 +2 1 0 1 14 7 50 -1 -1 3.000 0 0 -1 1 1 4 + 0 0 1.00 60.00 120.00 + 0 0 1.00 60.00 120.00 + 1425 8025 825 6750 825 2850 900 2700 +2 4 0 1 0 7 50 -1 -1 0.000 0 0 7 0 0 5 + 17025 10125 17025 9525 15750 9525 15750 10125 17025 10125 +2 1 0 1 0 7 50 -1 -1 3.000 0 0 -1 1 1 2 + 0 0 1.00 60.00 120.00 + 0 0 1.00 60.00 120.00 + 16050 9450 15525 8475 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 15825 11400 17175 11400 17175 11925 15825 11925 15825 11400 +2 1 0 1 0 7 50 -1 -1 3.000 0 0 -1 1 1 2 + 0 0 1.00 60.00 120.00 + 0 0 1.00 60.00 120.00 + 16350 10125 16350 11400 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 17550 10875 18900 10875 18900 11400 17550 11400 17550 10875 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 18375 9975 19725 9975 19725 10500 18375 10500 18375 9975 +2 1 0 1 0 7 50 -1 -1 3.000 0 0 -1 1 1 2 + 0 0 1.00 60.00 120.00 + 0 0 1.00 60.00 120.00 + 16725 10125 17850 10875 +2 1 0 1 0 7 50 -1 -1 3.000 0 0 -1 1 1 2 + 0 0 1.00 60.00 120.00 + 0 0 1.00 60.00 120.00 + 17025 9825 18375 10200 +2 1 0 1 14 7 50 -1 -1 3.000 0 0 -1 1 1 3 + 0 0 1.00 60.00 120.00 + 0 0 1.00 60.00 120.00 + 18975 9975 18075 8700 15900 7950 +2 2 0 1 0 7 50 -1 -1 3.000 0 0 -1 0 0 5 + 14100 6225 19950 6225 19950 12150 14100 12150 14100 6225 +2 1 0 1 0 7 50 -1 -1 3.000 0 0 -1 1 1 2 + 0 0 1.00 60.00 120.00 + 0 0 1.00 60.00 120.00 + 16575 9375 17850 7950 +2 2 0 1 0 7 50 -1 -1 3.000 0 0 -1 0 0 5 + 2100 10425 6150 10425 6150 14400 2100 14400 2100 10425 +2 2 0 1 0 7 50 -1 -1 3.000 0 0 -1 0 0 5 + 2325 10875 5925 10875 5925 13800 2325 13800 2325 10875 +2 2 0 1 0 7 50 -1 -1 3.000 0 0 -1 0 0 5 + 2400 10950 3975 10950 3975 11625 2400 11625 2400 10950 +2 4 0 1 0 7 50 -1 -1 0.000 0 0 7 0 0 5 + 5325 12675 5325 12075 4050 12075 4050 12675 5325 12675 +2 1 0 1 0 7 50 -1 -1 3.000 0 0 -1 1 0 2 + 0 0 1.00 60.00 120.00 + 3975 11250 4575 12075 +4 0 0 50 -1 0 12 0.0000 4 195 990 1800 2625 last_update\001 +4 0 0 50 -1 0 12 0.0000 4 150 690 3150 4125 main.db\001 +4 0 0 50 -1 0 12 0.0000 4 195 990 4200 3600 last_update\001 +4 0 0 50 -1 0 12 0.0000 4 180 1500 450 525 link tree /.db/*.db\001 +4 0 0 50 -1 0 12 0.0000 4 195 330 1950 6825 http\001 +4 0 0 50 -1 0 12 0.0000 4 180 870 1575 7950 run1/test1\001 +4 0 0 50 -1 0 12 0.0000 4 150 720 1650 5400 server-1\001 +4 0 0 50 -1 0 12 0.0000 4 150 1035 3675 6375 server-main\001 +4 0 0 50 -1 0 12 0.0000 4 150 375 2175 2025 2.db\001 +4 0 0 50 -1 0 12 0.0000 4 150 375 750 2550 1.db\001 +4 0 0 50 -1 0 12 0.0000 4 180 870 3450 7950 run1/test2\001 +4 0 0 50 -1 0 12 0.0000 4 150 1110 9675 3750 Dashboardm\001 +4 0 0 50 -1 0 12 0.0000 4 180 870 7275 1050 run2/test1\001 +4 0 0 50 -1 0 12 0.0000 4 150 720 6375 2850 server-2\001 +4 0 0 50 -1 0 12 1.5708 4 150 390 8325 3975 run1\001 +4 0 0 50 -1 0 12 0.0000 4 195 1905 9450 1650 pointers to the servers\001 +4 0 0 50 -1 0 12 0.0000 4 150 930 9600 375 monitor.db\001 +4 0 0 50 -1 0 12 0.0000 4 150 900 15825 9750 rpc-server\001 +4 0 0 50 -1 0 12 0.0000 4 165 270 17475 9900 tcp\001 +4 0 0 50 -1 0 12 0.0000 4 120 315 18525 10200 test\001 +4 0 0 50 -1 0 12 0.0000 4 195 1065 14850 7275 megatest.db\001 +4 0 0 50 -1 0 12 0.0000 4 195 1305 17700 7875 mysql/postgres\001 +4 0 0 50 -1 0 12 0.0000 4 195 1875 14325 6600 mysql/postgres model\001 +4 0 0 50 -1 0 12 0.0000 4 150 1140 600 8775 Current state\001 +4 0 0 50 -1 0 12 0.0000 4 195 4065 600 9300 Current state, no bypass - (if we switch to rpc?)\001 +4 0 0 50 -1 0 12 0.0000 4 195 1125 2175 10650 prev try RPC\001 +4 0 0 50 -1 0 12 0.0000 4 165 1095 2475 11100 rmt:get-tests\001 ADDED docs/inprogress/megatest-query-view.fig Index: docs/inprogress/megatest-query-view.fig ================================================================== --- /dev/null +++ docs/inprogress/megatest-query-view.fig @@ -0,0 +1,75 @@ +#FIG 3.2 Produced by xfig version 3.2.5-alpha5 +Landscape +Center +Inches +Letter +100.00 +Single +-2 +1200 2 +# Copyright 2006-2017, Matthew Welland. +# +# This file is part of Megatest. +# +# Megatest is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# Megatest is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with Megatest. If not, see . +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 900 675 4350 675 4350 1650 900 1650 900 675 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 1 0 2 + 0 0 1.00 60.00 120.00 + 4350 1200 6975 1725 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 6975 1350 10725 1350 10725 3075 6975 3075 6975 1350 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 1 0 2 + 0 0 1.00 60.00 120.00 + 7125 1800 8925 2025 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8850 1875 10125 1875 10125 2550 8850 2550 8850 1875 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 1 0 2 + 0 0 1.00 60.00 120.00 + 9825 2550 10125 6000 +2 4 0 1 0 7 50 -1 -1 0.000 0 0 7 0 0 5 + 11400 7350 11400 6000 9000 6000 9000 7350 11400 7350 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 1 0 2 + 0 0 1.00 60.00 120.00 + 9750 6000 9375 2550 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 1 0 2 + 0 0 1.00 60.00 120.00 + 8775 2250 7125 2025 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 1 0 2 + 0 0 1.00 60.00 120.00 + 6975 1800 4350 1275 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 975 3600 4350 3600 4350 4575 975 4575 975 3600 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 1 0 5 + 0 0 1.00 60.00 120.00 + 1050 1650 1050 2025 4575 2025 4575 1050 4350 1050 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 1 0 2 + 0 0 1.00 60.00 120.00 + 4350 3825 6975 2700 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 1 0 2 + 0 0 1.00 60.00 120.00 + 9000 2625 4350 4200 +4 0 0 50 -1 0 12 0.0000 4 150 390 1050 975 Test\001 +4 0 0 50 -1 0 12 0.0000 4 150 585 7125 1650 Server\001 +4 0 0 50 -1 0 12 0.0000 4 195 1020 4800 1125 http request\001 +4 0 0 50 -1 0 12 0.0000 4 195 750 9075 2100 db query\001 +4 0 0 50 -1 0 12 0.0000 4 150 345 9525 6375 disk\001 +4 0 0 50 -1 0 12 0.0000 4 195 1905 1725 1200 (rmt:tests-get-info ....)\001 +4 0 0 50 -1 0 12 0.0000 4 195 1905 1800 4125 (rmt:tests-get-info ....)\001 +4 0 0 50 -1 0 12 0.0000 4 195 1110 5100 3300 send-request\001 +4 0 0 50 -1 0 12 0.0000 4 150 2145 5475 3900 call-back with result data\001 +4 0 0 50 -1 0 12 0.0000 4 150 390 1125 3750 Test\001 +4 0 0 50 -1 0 12 0.0000 4 195 675 7350 2550 api.scm\001 +4 0 0 50 -1 0 12 0.0000 4 195 990 7350 2805 recieve-req\001 +4 0 0 50 -1 0 12 0.0000 4 150 1515 7350 3060 send-res-callback\001 ADDED docs/inprogress/megatest_qa.fig Index: docs/inprogress/megatest_qa.fig ================================================================== --- /dev/null +++ docs/inprogress/megatest_qa.fig @@ -0,0 +1,54 @@ +#FIG 3.2 Produced by xfig version 3.2.5-alpha5 +Landscape +Center +Inches +Letter +100.00 +Single +-2 +1200 2 +# Copyright 2006-2017, Matthew Welland. +# +# This file is part of Megatest. +# +# Megatest is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# Megatest is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with Megatest. If not, see . +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2 + 6000 300 6000 9675 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 525 675 4500 675 4500 2550 525 2550 525 675 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 900 1125 2325 1125 2325 1575 900 1575 900 1125 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2 + 225 150 225 7050 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 525 3150 3750 3150 3750 4275 525 4275 525 3150 +2 4 0 1 0 7 50 -1 -1 0.000 0 0 7 0 0 5 + 12750 5025 12750 750 6450 750 6450 5025 12750 5025 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9300 1725 10800 1725 10800 2100 9300 2100 9300 1725 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9300 2175 10800 2175 10800 2550 9300 2550 9300 2175 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 6750 1275 12600 1275 12600 2925 6750 2925 6750 1275 +2 4 0 1 0 7 50 -1 -1 0.000 0 0 7 0 0 5 + 12450 2700 12450 1650 6975 1650 6975 2700 12450 2700 +4 0 0 50 -1 0 12 0.0000 4 120 405 675 900 tests\001 +4 0 0 50 -1 0 12 0.0000 4 195 900 975 1425 nested_mt\001 +4 0 0 50 -1 0 12 0.0000 4 195 2790 675 3375 nested_mt (a full megatest suite)\001 +4 0 0 50 -1 0 12 0.0000 4 165 1110 375 5100 megatest_qa\001 +4 0 0 50 -1 0 12 0.0000 4 150 420 525 300 code\001 +4 0 0 50 -1 0 12 0.0000 4 150 1005 6750 375 Actual runs\001 +4 0 0 50 -1 0 12 0.0000 4 165 1710 6675 1050 outer megatest runs\001 +4 0 0 50 -1 0 12 0.0000 4 195 1785 6900 1500 test (e.g. nested_mt)\001 +4 0 0 50 -1 0 12 0.0000 4 195 1665 7125 1875 nested_mt testsuite\001 Index: docs/manual/Makefile ================================================================== --- docs/manual/Makefile +++ docs/manual/Makefile @@ -1,10 +1,27 @@ - +# Copyright 2006-2017, Matthew Welland. +# +# This file is part of Megatest. +# +# Megatest is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# Megatest is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# ASCPATH = $(shell which asciidoc) EXEPATH = $(shell readlink -f $(ASCPATH)) BINPATH = $(shell dirname $(EXEPATH)) DISPATH = $(shell dirname $(BINPATH)) +SRCFSL = $(shell fossil info | grep repository: | awk '{print $$2}') +INPAGES = plan.in howto.in reference.in getting_started.in # broad_goals.csv needed_features.csv : tables/*.dat # ./refdb2csv tables # in a makefile recipe, $< denotes the first dependency; $@ the target @@ -11,15 +28,18 @@ # design_spec.html : $(SRCFILES) $(CSVFILES) # asciidoc -b html5 -a icons -a iconsdir=$(DISPATH)/images/icons -a toc2 design_spec.txt # -all : server.ps megatest_manual.html client.ps complex-itemmap.png +all : server.ps megatest_manual.html client.ps complex-itemmap.png megatest_manual.pdf -megatest_manual.html : megatest_manual.txt getting_started.txt writing_tests.txt reference.txt ../plan.txt howto.txt *png +megatest_manual.html : megatest_manual.txt *.txt installation.txt *png *.dot asciidoc -b html5 -a icons -a iconsdir=$(DISPATH)/images/icons -a toc2 megatest_manual.txt # dos2unix megatest_manual.html + +megatest_manual.pdf : megatest_manual.txt *.txt *png *.dot + a2x -a toc -f pdf megatest_manual.txt server.ps : server.dot dot -Tps server.dot > server.ps client.ps : client.dot @@ -27,7 +47,13 @@ complex-itemmap.png : complex-itemmap.dot dot -Tpng complex-itemmap.dot -o complex-itemmap.png dot -Tpdf complex-itemmap.dot -o complex-itemmap.pdf +%.in : $(SRCFSL) + fossil wiki export $* $*.in + +# %.txt : %.in +# cp $*.in $*.txt + clean: rm -f megatest_manual.html ADDED docs/manual/bisecting.dot Index: docs/manual/bisecting.dot ================================================================== --- /dev/null +++ docs/manual/bisecting.dot @@ -0,0 +1,31 @@ +// Copyright 2021, Matthew Welland. +// +// This file is part of Megatest. +// +// Megatest is free software: you can redistribute it and/or modify +// it under the terms of the GNU General Public License as published by +// the Free Software Foundation, either version 3 of the License, or +// (at your option) any later version. +// +// Megatest is distributed in the hope that it will be useful, +// but WITHOUT ANY WARRANTY; without even the implied warranty of +// MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +// GNU General Public License for more details. +// +// You should have received a copy of the GNU General Public License +// along with Megatest. If not, see . +// +digraph G { + rankdir=LR + subgraph cluster_1 { + node [style=filled,shape=box]; + + B [label="B\nProblem is here"]; + E [label="E\nProblem manifests here"]; + A -> B; + B -> C; + C -> D; + D -> E; + } + +} ADDED docs/manual/bisecting.png Index: docs/manual/bisecting.png ================================================================== --- /dev/null +++ docs/manual/bisecting.png cannot compute difference between binary files Index: docs/manual/client.dot ================================================================== --- docs/manual/client.dot +++ docs/manual/client.dot @@ -1,5 +1,22 @@ +// Copyright 2006-2017, Matthew Welland. +// +// This file is part of Megatest. +// +// Megatest is free software: you can redistribute it and/or modify +// it under the terms of the GNU General Public License as published by +// the Free Software Foundation, either version 3 of the License, or +// (at your option) any later version. +// +// Megatest is distributed in the hope that it will be useful, +// but WITHOUT ANY WARRANTY; without even the implied warranty of +// MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +// GNU General Public License for more details. +// +// You should have received a copy of the GNU General Public License +// along with Megatest. If not, see . + digraph G { // put client after server so server_start node is visible // subgraph cluster_2 { Index: docs/manual/complex-itemmap.dot ================================================================== --- docs/manual/complex-itemmap.dot +++ docs/manual/complex-itemmap.dot @@ -1,5 +1,22 @@ +// Copyright 2006-2017, Matthew Welland. +// +// This file is part of Megatest. +// +// Megatest is free software: you can redistribute it and/or modify +// it under the terms of the GNU General Public License as published by +// the Free Software Foundation, either version 3 of the License, or +// (at your option) any later version. +// +// Megatest is distributed in the hope that it will be useful, +// but WITHOUT ANY WARRANTY; without even the implied warranty of +// MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +// GNU General Public License for more details. +// +// You should have received a copy of the GNU General Public License +// along with Megatest. If not, see . + digraph G { // put client after server so server_start node is visible // subgraph cluster_1 { @@ -38,10 +55,10 @@ label = "Test E"; "C/1/bb" -> "E/1/res"; "C/2/bb" -> "E/2/res"; } - label = "Complex Itemmapping"; + label = "Complex Itemmapping (arrows indicate order of execution)"; color=green; } } Index: docs/manual/complex-itemmap.png ================================================================== --- docs/manual/complex-itemmap.png +++ docs/manual/complex-itemmap.png cannot compute difference between binary files ADDED docs/manual/debugging.txt Index: docs/manual/debugging.txt ================================================================== --- /dev/null +++ docs/manual/debugging.txt @@ -0,0 +1,294 @@ +// Copyright 2021, Matthew Welland. +// +// This file is part of Megatest. +// +// Megatest is free software: you can redistribute it and/or modify +// it under the terms of the GNU General Public License as published by +// the Free Software Foundation, either version 3 of the License, or +// (at your option) any later version. +// +// Megatest is distributed in the hope that it will be useful, +// but WITHOUT ANY WARRANTY; without even the implied warranty of +// MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +// GNU General Public License for more details. +// +// You should have received a copy of the GNU General Public License +// along with Megatest. If not, see . + +Debugging +--------- + +Well Written Tests +~~~~~~~~~~~~~~~~~~ + +Test Design and Surfacing Errors +^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + +Design your tests to surface errors. Ensure that all logs are +processed by logpro (or a custom log processing tool) and can be +reached by a mouse click or two from the test control panel. + +To illustrate, here is a set of scripts with nested calls where script1.sh calls script2.sh which calls script3.sh which finally calls the Cadence EDA tool virtuoso: + +.script1.sh +.............................. +#!/bin/bash +code ... +script2.sh some parameters > script2.log +more code ... +.............................. + +.script2.sh +.............................. +#!/bin/bash +code ... +script3.sh some more parameters > script3.log +more code ... +.............................. + +.script3.sh +.............................. +#!/bin/bash +code ... +virtuoso params and switches ... +more code ... +.............................. + +The log files script2.log, script3.log and the log output from +virtuoso are not accessible from the test control panel. It would be +much better for future users of your automation to use steps more +fully. One easy option would be to post process the logs in downstream +additional steps: + +.testconfig +.............................. +[ezsteps] +step1 script1.sh +step2 cat script2.log +step3 cat script3.log + +[logpro] +step1 ;; some logpro rules + (expect:required in "LogFileBody" > 0 "Expect this output" #/something expected/) +step2 ;; some logpro rules for script2.sh +step3 ;; some logpro rules for script3.sh + +[scripts] +script1.sh #!/bin/bash + code ... + +... +.............................. + +With the above testconfig the logs for every critical part of the +automation are fully surfaced and rules can be created to flag errors, +warnings, aborts and to ignore false errors. A user of your automation +will be able to see the important error with two mouse clicks from the +runs view. + +An even better would be to eliminate the nesting if possible. As a +general statement with layers - less is usually more. By flattening +the automation into a sequence of steps you can use the test control +panel to re-run a step with a single click or from the test xterm run +only the errant step from the command line. + +The message here is make debugging and maintenace easy for future +users (and yourself) by keeping clicks-to-error in mind. + +Examining The Test Logs and Environment +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Test Control Panel - xterm +^^^^^^^^^^^^^^^^^^^^^^^^^^ + +From the dashboard click on a test PASS/FAIL button. This brings up a +test control panel. Aproximately near the center left of the window +there is a button "Start Xterm". Push this to get an xterm with the +full context and environment loaded for that test. You can run scripts +or ezsteps by copying from the testconfig (hint, load up the +testconfig in a separate text editor window). + +With more recent versions of Megatest you can step through your test +from the test control panel. Click on the cell labeled "rerun this +step" to only rerun the step or click on "restart from here" to rerun +that step and downstream steps. + +NOTE 1: visual feedback can take some time, give it a few seconds and +you will see the step change color to blue as it starts running. + +NOTE 2: steping through only works if you are using ezsteps. + +A word on Bisecting +~~~~~~~~~~~~~~~~~~~ + +Bisecting is a debug strategy intended to speed up finding the root +cause of some bug. + +.A complex process with a problem found in stage "E" +["graphviz", "bisecting.png"] +---------------------------------------------------------------------- +include::bisecting.dot[] +---------------------------------------------------------------------- + +It is common to start debugging where the problem was observed and +then work back. However by inspecting the output at stage "C" in the +example above you would potentially save a lot of debug effort, this +is similar to the feature in source control tools like git and fossil +called biseceting. + +Tough Bugs +~~~~~~~~~~ + +Most bugs in Megatest based automation will be in the scripts called +in your test steps and if you utilize the good design practice +described above should be fairly easy for you to reproduce, isolate +and find. + +Some bugs however will come from subtle and hard to detect +interactions between Megatest and your OS and Unix environment. This +includes things like constructed variables that are legal in one +context (e.g. tcsh) but illegal in another context (e.g. bash), +variables that come from your login scripts and access and permissions +issues (e.g. a script that silently fails due to no access to needed +data). Other bugs might be due to Megatest itself. + +To isolate bugs like this you may need to look at the log files at +various stages in the execution process of your run and tests. + +.A simplified diagram of the stages Megatest goes through to run a test. +["graphviz", "megatest-test-stages.png"] +---------------------------------------------------------------------- +include::megatest-test-stages.dot[] +---------------------------------------------------------------------- + +.How to check variable values and inspect logs at each stage +[width="80%",cols="<,2m,2m",frame="topbot",options="header"] +|====================== +|Stage | How to inspect | Watch for +|A: post config processing | megatest -show-config -target your/target | #f (failed var processing) +|B: post runconfig | megatest -show-runconfig -target your/target | Add -debug 0,9 to see which file your settings come from +|C: processing testconfigs | inspect output from "megatest -run ..." | Messages indicating issues process configs, dependency problems +|D: process testconfig for test launch | inspect output from megatest runner | Zero items (items expansion yielded no items) +|E,F: launching test | start test xterm, look at mt_launch.log | Did your batch system accept the job? Has the job landed on a machine? +|G: starting test | look at your batch systems logs for the process | Did the megatest -execute process start and run? +|H,H1,H2: step exectution | look at .log, .html and your own internal logs | Do you have sufficiently tight logpro rules? You must always have a "required" rule! +|====================== + +Bisecting megatest.csh/sh +^^^^^^^^^^^^^^^^^^^^^^^^^ + +Sometimes finding the environment variable that is causing the problem +can be very difficult. Bisection can be applied. + +Edit the megatest.csh or megatest.sh file and comment out 50% per +round, source in fresh xterm and run the test. + +This idea can also be applied to your .cshrc, .bashrc, .aliases and +other similar files. + +csh and -f +^^^^^^^^^^ + +A common issue when tcsh or csh shells are used for scripting is to +forget or choose to not use -f in your #! line. + +.Not good +.............................. +#!/bin/tcsh +... +.............................. + +.Good +.............................. +#!/bin/tcsh -f +... +.............................. + + +Config File Processing +^^^^^^^^^^^^^^^^^^^^^^ + +As described above it is often helpful to know the content of +variables in various contexts as Megatest works through the actions +needed to run your tests. A handy technique is to force the startup of +an xterm in the context being examined. + +For example, if an item list is not being generated as expected you +can inject the startup of an xterm as if it were an item: + +.Original items table +----------------- +[items] +CELLNAME [system getcellname.sh] +----------------- + +.Items table modified for debug +----------------- +[items] +DEBUG [system xterm] +CELLNAME [system getcellnames.sh] +----------------- + +When this test is run an xterm will pop up. In that xterm the +environment is exactly that in which the script "getcellnames.sh" +would run. You can now debug the script to find out why it isn't +working as expected. + +NOTE: This technique can be very helpful in debugging running of EDA tools in Perl, Ruby, Python or tcl scripts: + +.Perl example +.............................. +some_code(); +$cmdline="virtuoso -some-switches and params ..."; +print "$cmdline"; # print the command line so you can paste it into the xterm that pops up +system("xterm"); # this line is added for the debug and removed when done +system($cmdline); +more_code(); +.............................. + +Misc Other Debugging Hints +~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Annotating scripts and config files +^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + +Run the "env" command to record the environment: + +env | sort > stagename.log + +In a config file: + +.megatest.config, runconfigs.config and testconfig +................... +#{shell env | sort > stagename.log} + +# or + +[system env | sort > stagename.log] +................... + +In scripts just insert the commands, this example helps you identify +if "some commands ..." changed any environment variables.: + +.myscript.sh +.............................. +env > somefile-before.log +some commands ... +env > somefile-after.log +.............................. + +.Use meld to examine the differences +.............................. +meld somefile-before.log somefile-after.log +.............................. + +Start an xterm to examine the environment, run scripts etc: + +In a config file: + +.megatest.config, runconfigs.config and testconfig files +.............................. +#{shell xterm} (this blocks) +.............................. + +Similarly in a script just call the xterm. ADDED docs/manual/devnotes.txt Index: docs/manual/devnotes.txt ================================================================== --- /dev/null +++ docs/manual/devnotes.txt @@ -0,0 +1,37 @@ +Developer Notes +--------------- + +Collected here are some topics that may interest the megatest developer. + +telemetry +~~~~~~~~~ + +A new feature introduced in v1.6525 allows a centralized debug messaging system. Debugging client-server issues +is greatly aided by a centralized, time coherent log of events across test execution, server, and runner. This +is provided by the telemetry feature + + +source code call example + + +[source,ini] + [telemetry] + host + port + want-events + + +Usage: +1. Add telemetry section to megatest.config +2. Start telemetry daemon telemetry-daemon -a start -l /tmp/my-telemetry.log +3. Run megatest +4. examine / parse telemetry log Index: docs/manual/getting_started.txt ================================================================== --- docs/manual/getting_started.txt +++ docs/manual/getting_started.txt @@ -1,81 +1,115 @@ +// This file is part of Megatest. +// +// Megatest is free software: you can redistribute it and/or modify +// it under the terms of the GNU General Public License as published by +// the Free Software Foundation, either version 3 of the License, or +// (at your option) any later version. +// +// Megatest is distributed in the hope that it will be useful, +// but WITHOUT ANY WARRANTY; without even the implied warranty of +// MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +// GNU General Public License for more details. +// +// You should have received a copy of the GNU General Public License +// along with Megatest. If not, see . +// +// Copyright 2006-2012, Matthew Welland. Getting Started -=============== +--------------- -[partintro] +// [partintro] .Getting started with Megatest --- -How to install Megatest and set it up for running your regressions and continuous integration process. --- - -Installation ------------- - -Dependencies -~~~~~~~~~~~~ - -Chicken scheme and a number of "eggs" are required for building -Megatest. See the script installall.sch in the utils directory of the -distribution for a mostly automated way to install everything needed -for building Megatest on Linux. - -footnote:[An example footnote.] -indexterm:[Example index entry] - -// -// -// And now for something completely different: ((monkeys)), lions and -// tigers (Bengal and Siberian) using the alternative syntax index -// entries. -// (((Big cats,Lions))) -// (((Big cats,Tigers,Bengal Tiger))) -// (((Big cats,Tigers,Siberian Tiger))) -// Note that multi-entry terms generate separate index entries. -// -// Here are a couple of image examples: an image:images/smallnew.png[] -// example inline image followed by an example block image: -// -// .Tiger block image -// image::images/tiger.png[Tiger image] -// -// Followed by an example table: -// -// .An example table -// [width="60%",options="header"] -// |============================================== -// | Option | Description -// | -a 'USER GROUP' | Add 'USER' to 'GROUP'. -// | -R 'GROUP' | Disables access to 'GROUP'. -// |============================================== -// -// .An example example -// =============================================== -// Lorum ipum... -// =============================================== -// -// [[X1]] -// Sub-section with Anchor -// ~~~~~~~~~~~~~~~~~~~~~~~ -// Sub-section at level 2. -// -// Chapter Sub-section -// ^^^^^^^^^^^^^^^^^^^ -// Sub-section at level 3. -// -// Chapter Sub-section -// +++++++++++++++++++ -// Sub-section at level 4. -// -// This is the maximum sub-section depth supported by the distributed -// AsciiDoc configuration. -// footnote:[A second example footnote.] -// -// -// The Second Chapter -// ------------------ -// An example link to anchor at start of the <>. -// indexterm:[Second example index entry] -// -// An example link to a bibliography entry <>. -// -// +------------------- +Creating a testsuite or flow and your first test or task. +------------------- + +After installing Megatest you can create a flow or testsuite and add some +tests using the helpers. Here is a quickstart sequence to get you up and +running your first automated testsuite. + +Creating a Megatest Area +~~~~~~~~~~~~~~~~~~~~~~~~ + +Choose Target Keys +^^^^^^^^^^^^^^^^^^ + +First choose your "target" keys. These are used to organise your runs in a +way that is meaningful to your project. If you are unsure about what to use +for keys just use a single generic key such as "RUNTYPE". These keys will be +used to hand values to your tests via environment variables so ensure they +are unique. Prefixing them with something such as PROJKEYS_ is a good +strategy. + +Examples of keys: + +.Example keys +[width="60%",options="header"] +|============================================== +| Option | Description +| RELEASE/ITERATION | This example is used by Megatest for its internal QA. +| ARCH/OS/RELEASE | For a software project targeting multiple platforms +| UCTRLR/NODETYPE | Microcontroller project with different controllers +running same software +|============================================== + +Create Area Config Files +^^^^^^^^^^^^^^^^^^^^^^^^ + +You will need to choose locations for your runs (the data generated every +time you run the testsuite) and link tree. For getting started answer the +prompts with "runs" and "links". We use the Unix editor "vi" in the examples +below but you can use any plain text editor. + +.Using the helper to create a Megatest area +------------------ +megatest -create-megatest-area + +# optional: verify that the settings are ok +vi megatest.config +vi runconfigs.config +------------------ + +Creating a Test +~~~~~~~~~~~~~~~ + +Choose the test name for your first test and run the helper. You can edit +the files after the initial creation. You will need to enter names and +scripts for the steps to be run and then edit the +tests//testconfig file and modify the logpro rules to properly +process the log output from your steps. For your first test just hit enter +for the "waiton", "priority" and iteration variable prompts. + +Hint: for geting started make your logpro rules very liberal. expect:error +patterns should match nothing and comment out expect:required rules. + +.Using the helper to create a Megatest test +--------------- +megatest -create-test myfirsttest + +# then edit the generated config +vi tests/myfirsttest/testconfig +--------------- + +Running your test +~~~~~~~~~~~~~~~~~ + +First choose a target and runname. If you have a two-place target such as +RELEASE/ITERATION a target would look like v1.0/aff3 where v1.0 is the +RELEASE and aff3 is the ITERATION. For a run name just use something like +run1. + +.Running all tests (testpatt of "%" matches all tests) +--------------- +megatest -run -target v1.0/aff3 -runname run1 -testpatt % -log run1.log +--------------- + +Viewing the results +~~~~~~~~~~~~~~~~~~~ + +Start the dashboard and browse your run in the "Runs" tab. + +.Starting dashboard +---------------- +dashboard -rows 24 +---------------- Index: docs/manual/howto.txt ================================================================== --- docs/manual/howto.txt +++ docs/manual/howto.txt @@ -1,14 +1,30 @@ +// This file is part of Megatest. +// +// Megatest is free software: you can redistribute it and/or modify +// it under the terms of the GNU General Public License as published by +// the Free Software Foundation, either version 3 of the License, or +// (at your option) any later version. +// +// Megatest is distributed in the hope that it will be useful, +// but WITHOUT ANY WARRANTY; without even the implied warranty of +// MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +// GNU General Public License for more details. +// +// You should have received a copy of the GNU General Public License +// along with Megatest. If not, see . +// +// Copyright 2006-2012, Matthew Welland. How To Do Things -================ +---------------- Process Runs ------------- +~~~~~~~~~~~~ Remove Runs -~~~~~~~~~~~ +^^^^^^^^^^^ From the dashboard click on the button (PASS/FAIL...) for one of the tests. From the test control panel that comes up push the clean test button. The command field will be prefilled with a template command for removing that test. You can edit the command, for example change the argument to -testpatt to "%" to remove all tests. @@ -21,30 +37,30 @@ ---------------- megatest -remove-runs -target %/%/% -runname % -testpatt % -v ---------------- Archive Runs -~~~~~~~~~~~~ +^^^^^^^^^^^^ Megatest supports using the bup backup tool (https://bup.github.io/) to archive your tests for efficient storage and retrieval. Archived data can be rapidly retrieved if needed. The metadata for the run (PASS/FAIL status, run durations, time stamps etc.) are all preserved in the megatest database. For setup information see the Archiving topic in the reference section of this manual. To Archive -^^^^^^^^^^ +++++++++++ Hint: use the test control panel to create a template command by pushing the "Archive Tests" button. .Archive a full run ---------------- megatest -target ubuntu/nfs/none -runname ww28.1a -archive save-remove -testpatt % ---------------- To Restore -^^^^^^^^^^ +++++++++++ .Retrieve a single test ---------------- megatest -target ubuntu/nfs/none -runname ww28.1a -archive restore -testpatt diskperf/% ---------------- @@ -52,10 +68,27 @@ Hint: You can browse the archive using bup commands directly. ---------------- bup -d /path/to/bup/archive ftp ---------------- + +Pass Data from Test to Test +~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +.To save the data call archive save within your test: +---------------- +megatest -archive save +---------------- + +.To retrieve the data call archive get using patterns as needed +---------------- +# Put the retrieved data into /tmp +DESTPATH=/tmp/$USER/$MT_TARGET/$MT_RUN_NAME/$MT_TESTNAME/$MT_ITEMPATH/my_data +mkdir -p $DESTPATH +megatest -archive get -runname % -dest $DESTPATH +---------------- + Submit jobs to Host Types based on Test Name ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ .In megatest.config @@ -77,18 +110,18 @@ # if defined and not "no" flexi-launcher will bypass launcher unless there is no # match. flexi-launcher yes ------------------------ -Tricks -====== +Tricks and Tips +--------------- -This section is a compendium of a various useful tricks for debugging, -configuring and generally getting the most out of Megatest. +This section is a collection of a various useful tricks for that +didn't quite fit elsewhere. Limiting your running jobs --------------------------- +~~~~~~~~~~~~~~~~~~~~~~~~~~ The following example will limit a test in the jobgroup "group1" to no more than 10 tests simultaneously. In your testconfig: @@ -104,53 +137,10 @@ group1 10 custdes 4 --------------- - - -Debugging Tricks ----------------- - -Examining The Environment -~~~~~~~~~~~~~~~~~~~~~~~~~ - -Test Control Panel - xterm -^^^^^^^^^^^^^^^^^^^^^^^^^^ - -From the dashboard click on a test PASS/FAIL button. This brings up a test control panel. Aproximately near the center left of the -window there is a button "Start Xterm". Push this to get an xterm with the full context and environment loaded for that test. You can run -scripts or ezsteps by copying from the testconfig (hint, load up the testconfig in a separate gvim or emacs window). This is the easiest way -to debug your tests. - -During Config File Processing -^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ - -It is often helpful to know the content of variables in various -contexts as Megatest does the actions needed to run your tests. A handy technique is to force the startup of an xterm in the context being examined. - -For example, if an item list is not being generated as expected you -can inject the startup of an xterm as if it were an item: - -.Original items table ------------------ -[items] -CELLNAME [system getcellname.sh] ------------------ - -.Items table modified for debug ------------------ -[items] -DEBUG [system xterm] -CELLNAME [system getcellnames.sh] ------------------ - -When this test is run an xterm will pop up. In that xterm the -environment is exactly that in which the script "getcellnames.sh" -would run. You can now debug the script to find out why it isn't -working as expected. - Organising Your Tests and Tasks ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ The default location "tests" for storing tests can be extended by adding to your tests-paths section. ADDED docs/manual/installation.txt Index: docs/manual/installation.txt ================================================================== --- /dev/null +++ docs/manual/installation.txt @@ -0,0 +1,55 @@ +// Copyright 2006-2017, Matthew Welland. +// +// This file is part of Megatest. +// +// Megatest is free software: you can redistribute it and/or modify +// it under the terms of the GNU General Public License as published by +// the Free Software Foundation, either version 3 of the License, or +// (at your option) any later version. +// +// Megatest is distributed in the hope that it will be useful, +// but WITHOUT ANY WARRANTY; without even the implied warranty of +// MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +// GNU General Public License for more details. +// +// You should have received a copy of the GNU General Public License +// along with Megatest. If not, see . + +Installation +------------ + +Dependencies +~~~~~~~~~~~~ + +Chicken scheme and a number of "eggs" are required for building +Megatest. See the script installall.sh in the utils directory of the +source distribution for an automated way to install everything +needed for building Megatest on Linux. + +Megatest. In the v1.66 and beyond assistance to create the build +system is built into the Makefile. + +.Installation steps (overview) +------------------------------------- +./configure +make chicken +setup.sh make -j install +------------------------------------- + +Or install the needed build system manually: + +. Chicken scheme from http://call-cc.org +. IUP from http://webserver2.tecgraf.puc-rio.br/iup/ +. CD from http://webserver2.tecgraf.puc-rio.br/cd/ +. IM from https://webserver2.tecgraf.puc-rio.br/im/ +. ffcall from http://webserver2.tecgraf.puc-rio.br/iup/ +. Nanomsg from https://nanomsg.org/ (NOTE: Plan is to eliminate nanomsg dependency). +. Needed eggs (look at the eggs lists in the Makefile) + +Then follow these steps: + +.Installation steps (self-built chicken scheme build system) +------------------------------------- +./configure +make -j install +------------------------------------- Index: docs/manual/itemmap.fig ================================================================== --- docs/manual/itemmap.fig +++ docs/manual/itemmap.fig @@ -1,6 +1,6 @@ -#FIG 3.2 Produced by xfig version 3.2.5c +#FIG 3.2 Produced by xfig version 3.2.5-alpha5 Landscape Center Metric A4 100.00 @@ -38,10 +38,26 @@ 0 60 #000049 0 61 #797979 0 62 #303430 0 63 #414141 0 64 #c7b696 +# Copyright 2006-2017, Matthew Welland. +# +# This file is part of Megatest. +# +# Megatest is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# Megatest is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with Megatest. If not, see . 6 3600 2700 4455 3555 2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 3600 2700 4050 2700 4050 3150 3600 3150 3600 2700 2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 3690 3150 3690 3285 4185 3285 4185 2790 4050 2790 @@ -89,23 +105,23 @@ 5625 5085 5625 5220 6120 5220 6120 4725 5985 4725 2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 5760 5220 5760 5355 6255 5355 6255 4860 6120 4860 -6 6 6840 2790 8910 3420 -4 0 0 50 -1 0 12 0.0000 4 180 1260 6840 2970 [requirements]\001 -4 0 0 50 -1 0 12 0.0000 4 135 990 6840 3165 waiton TstE\001 -4 0 0 50 -1 0 12 0.0000 4 180 2070 6840 3360 itemap foo/(\\d+) \\1/bar\001 +4 0 0 50 -1 0 12 0.0000 4 195 1290 6840 2970 [requirements]\001 +4 0 0 50 -1 0 12 0.0000 4 150 1050 6840 3165 waiton TstE\001 +4 0 0 50 -1 0 12 0.0000 4 195 1950 6840 3360 itemap foo/(\\d+) \\1/bar\001 -6 6 6840 6345 8910 6975 -4 0 0 50 -1 0 12 0.0000 4 180 1260 6840 6525 [requirements]\001 -4 0 0 50 -1 0 12 0.0000 4 135 990 6840 6720 waiton TstE\001 -4 0 0 50 -1 0 12 0.0000 4 180 2070 6840 6915 itemap baz/(\\d+) \\1/bar\001 +4 0 0 50 -1 0 12 0.0000 4 195 1290 6840 6525 [requirements]\001 +4 0 0 50 -1 0 12 0.0000 4 150 1050 6840 6720 waiton TstE\001 +4 0 0 50 -1 0 12 0.0000 4 195 1980 6840 6915 itemap baz/(\\d+) \\1/bar\001 -6 6 3600 6570 4860 7200 -4 0 0 50 -1 0 12 0.0000 4 180 810 3600 6750 [itemmap]\001 -4 0 0 50 -1 0 12 0.0000 4 150 1260 3600 6945 TstA .*/ foo/\001 -4 0 0 50 -1 0 12 0.0000 4 165 1080 3600 7140 TstB ab/ xy/\001 +4 0 0 50 -1 0 12 0.0000 4 195 900 3600 6750 [itemmap]\001 +4 0 0 50 -1 0 12 0.0000 4 180 1140 3600 6945 TstA .*/ foo/\001 +4 0 0 50 -1 0 12 0.0000 4 195 1050 3600 7140 TstB ab/ xy/\001 -6 2 1 0 2 0 7 50 -1 -1 0.000 0 0 -1 1 0 2 0 0 1.00 60.00 120.00 5355 4455 4500 3600 2 1 0 2 0 7 50 -1 -1 0.000 0 0 -1 1 0 2 @@ -132,18 +148,18 @@ 2 1 0 2 23 7 50 -1 -1 0.000 0 0 -1 1 0 3 0 0 1.00 60.00 120.00 7065 6255 7065 5715 6390 5130 2 2 0 2 7 7 50 -1 -1 0.000 0 0 -1 0 0 5 900 0 9000 0 9000 7425 900 7425 900 0 -4 0 0 50 -1 0 12 0.0000 4 135 360 1935 4725 TstB\001 -4 0 0 50 -1 0 12 0.0000 4 135 360 5445 1170 TstC\001 -4 0 0 50 -1 0 12 0.0000 4 135 360 5445 4770 TstD\001 -4 0 0 50 -1 0 12 0.0000 4 135 360 3600 2970 TstE\001 -4 0 0 50 -1 0 12 0.0000 4 135 360 1845 1170 TstA\001 -4 0 0 50 -1 0 12 0.0000 4 135 720 5085 450 runthird\001 -4 0 0 50 -1 0 12 0.0000 4 135 810 3330 405 runsecond\001 -4 0 0 50 -1 0 12 0.0000 4 135 720 1575 405 runfirst\001 -4 0 0 50 -1 0 12 0.0000 4 150 1260 6750 1005 2. TstE starts\001 -4 0 0 50 -1 0 12 0.0000 4 150 1800 6750 1215 3. TstC & TstD start\001 -4 0 0 50 -1 0 12 0.0000 4 150 1800 6750 810 1. TstA & TstB start\001 -4 0 0 50 -1 0 12 0.0000 4 180 1260 3600 6165 [requirements]\001 -4 0 0 50 -1 0 12 0.0000 4 135 1440 3600 6360 waiton TstA TstB\001 +4 0 0 50 -1 0 12 0.0000 4 150 420 1935 4725 TstB\001 +4 0 0 50 -1 0 12 0.0000 4 150 435 5445 1170 TstC\001 +4 0 0 50 -1 0 12 0.0000 4 150 435 5445 4770 TstD\001 +4 0 0 50 -1 0 12 0.0000 4 150 420 3600 2970 TstE\001 +4 0 0 50 -1 0 12 0.0000 4 150 450 1845 1170 TstA\001 +4 0 0 50 -1 0 12 0.0000 4 150 675 5085 450 runthird\001 +4 0 0 50 -1 0 12 0.0000 4 150 900 3330 405 runsecond\001 +4 0 0 50 -1 0 12 0.0000 4 150 615 1575 405 runfirst\001 +4 0 0 50 -1 0 12 0.0000 4 150 1155 6750 1005 2. TstE starts\001 +4 0 0 50 -1 0 12 0.0000 4 150 1770 6750 1215 3. TstC & TstD start\001 +4 0 0 50 -1 0 12 0.0000 4 150 1770 6750 810 1. TstA & TstB start\001 +4 0 0 50 -1 0 12 0.0000 4 195 1290 3600 6165 [requirements]\001 +4 0 0 50 -1 0 12 0.0000 4 150 1545 3600 6360 waiton TstA TstB\001 ADDED docs/manual/megatest-stand-alone-area.png Index: docs/manual/megatest-stand-alone-area.png ================================================================== --- /dev/null +++ docs/manual/megatest-stand-alone-area.png cannot compute difference between binary files ADDED docs/manual/megatest-system-architecture.png Index: docs/manual/megatest-system-architecture.png ================================================================== --- /dev/null +++ docs/manual/megatest-system-architecture.png cannot compute difference between binary files ADDED docs/manual/megatest-system-architecture.svg Index: docs/manual/megatest-system-architecture.svg ================================================================== --- /dev/null +++ docs/manual/megatest-system-architecture.svg @@ -0,0 +1,5662 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + image/svg+xml + + + + + + + + + + + + run control + + + storageallocation + + + + + + + + + area/testsuite state/status database + configs and custom automation + + + + + run control + + + storageallocation + + + + + + + + + area/testsuite state/status database + configs and custom automation + + + + + + + + + + + compute cloud storage (NFS, moosefs etc.) + + job + + + job + + + job + + + + + run control + + + storageallocation + + + + + + + + + area/testsuite state/status database + configs and custom automation + + + + + + + + + + + + + + + + + postgresql database sync + + + + + + multi-area dashboard and xterm + + + + + multi-area web direct read and control + + multi-area control:- contours- sub-runs- file/vcs sensors- events + configs and custom automation + Megatest Full System Architecture + ADDED docs/manual/megatest-test-stages.dot Index: docs/manual/megatest-test-stages.dot ================================================================== --- /dev/null +++ docs/manual/megatest-test-stages.dot @@ -0,0 +1,42 @@ +// Copyright 2021, Matthew Welland. +// +// This file is part of Megatest. +// +// Megatest is free software: you can redistribute it and/or modify +// it under the terms of the GNU General Public License as published by +// the Free Software Foundation, either version 3 of the License, or +// (at your option) any later version. +// +// Megatest is distributed in the hope that it will be useful, +// but WITHOUT ANY WARRANTY; without even the implied warranty of +// MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +// GNU General Public License for more details. +// +// You should have received a copy of the GNU General Public License +// along with Megatest. If not, see . +// +digraph G { + // rankdir=LR + subgraph cluster_1 { + node [style=filled,shape=box]; + A [label="A: Process megatest.config"] + B [label="B: Process runconfig.config"] + A -> B [label="resolve vars"] + B2 [label="B2: Resolve variables"] + B -> B2 -> A + C [label="C: Process testconfigs (find tests to run)"] + D [label="D: Process testconfig for test of interest"] + E [label="E: Set vars for launching test"] + F [label="F: Launch into batch system, ssh, batch system\nand different hosts can all \nimpact variable values"] + G [label="G: Process testconfig again with all available variables"] + H [label="H: Start test"] + H1 [label="H1: Start step"] + H2 [label="H2: Execute step script"] + I [label="I: End step, process logfile with logpro"] + I -> H [label="Run remaining steps"] + H-> H1 -> H2 -> I + B->C->D->E->F->G->H + I->D + } + +} ADDED docs/manual/megatest-test-stages.png Index: docs/manual/megatest-test-stages.png ================================================================== --- /dev/null +++ docs/manual/megatest-test-stages.png cannot compute difference between binary files Index: docs/manual/megatest_manual.html ================================================================== --- docs/manual/megatest_manual.html +++ docs/manual/megatest_manual.html @@ -1,10 +1,10 @@ - + The Megatest Users Manual + + + +EOF +) + +(define tests:css-jscript-block-dynamic +#< +EOF +) + +(define (test:js-block javascript-lib) + (conc "" )) + + +(define tests:css-jscript-block-static (test:js-block *java-script-lib*)) + +(define (tests:css-jscript-block-cond dynamic) + (if (equal? dynamic #t) + tests:css-jscript-block-dynamic + tests:css-jscript-block-static)) + + +(define (tests:run-record->test-path run numkeys) + (append (take (vector->list run) numkeys) + (list (vector-ref run (+ 1 numkeys))))) + + +(define (tests:get-rest-data runs header numkeys) + (let ((resh (make-hash-table))) + (for-each + (lambda (run) + (let* ((run-id (db:get-value-by-header run header "id")) + (run-dir (tests:run-record->test-path run numkeys)) + (test-data (rmt:get-tests-for-run + run-id + "%" ;; testnamepatt + '() ;; states + '() ;; statuses + #f ;; offset + #f ;; num-to-get + #f ;; hide/not-hide + #f ;; sort-by + #f ;; sort-order + #f ;; 'shortlist ;; qrytype + 0 ;; last update + #f))) + + (map (lambda (test) + (let* ((test-name (vector-ref test 2)) + (test-html-path (conc (vector-ref test 10) "/" (vector-ref test 13))) + (test-item (conc test-name ":" (vector-ref test 11))) + (test-status (vector-ref test 4))) + + (if (not (hash-table-ref/default resh test-name #f)) + (hash-table-set! resh test-name (make-hash-table))) + (if (not (hash-table-ref/default (hash-table-ref/default resh test-name #f) test-item #f)) + (hash-table-set! (hash-table-ref/default resh test-name #f) test-item (make-hash-table))) + (hash-table-set! (hash-table-ref/default (hash-table-ref/default resh test-name #f) test-item #f) run-id (list test-status test-html-path)))) + test-data))) + runs) + resh)) + + +;; tests:genrate dashboard body +;; + +(define (tests:dashboard-body page pg-size keys numkeys total-runs linktree area-name get-prev-links get-next-links flag run-patt target-patt) + (let* ((start (* page pg-size)) + ;(runsdat (rmt:get-runs "%" pg-size start (map (lambda (x)(list x "%")) keys))) + (runsdat (rmt:get-runs-by-patt keys run-patt target-patt start pg-size #f 0 sort-order: "desc")) + ; db:get-runs-by-patt keys runnamepatt targpatt offset limit fields last-update + (header (vector-ref runsdat 0)) + (runs (vector-ref runsdat 1)) + (ctr 0) + (test-runs-hash (tests:get-rest-data runs header numkeys)) + (test-list (hash-table-keys test-runs-hash))) + + (s:html tests:css-jscript-block (tests:css-jscript-block-cond flag) + (s:title "Summary for " area-name) + (s:body 'onload "addEvents();" + (get-prev-links page linktree) + (get-next-links page linktree total-runs) + + (s:h1 "Summary for " area-name) + (s:h3 "Filter" ) + (s:input 'type "text" 'name "testname" 'id "testname" 'length "30" 'onkeyup "filtersome()") + ;; top list + + (s:table 'id "LinkedList1" 'border "1" 'cellspacing 0 + (map (lambda (key) + (let* ((res (s:tr 'class "something" + (s:th key ) + (map (lambda (run) + (s:th (vector-ref run ctr))) + runs)))) + (set! ctr (+ ctr 1)) + res)) + keys) + (s:tr + (s:th "Run Name") + (map (lambda (run) + (s:th (db:get-value-by-header run header "runname"))) + runs)) + + (map (lambda (test-name) + (let* ((item-hash (hash-table-ref/default test-runs-hash test-name #f)) + (item-keys (sort (hash-table-keys item-hash) string<=?))) + (map (lambda (item-name) + (let* ((res (s:tr 'class item-name + (s:td item-name 'class "test" ) + (map (lambda (run) + (let* ((run-test (hash-table-ref/default item-hash item-name #f)) + (run-id (db:get-value-by-header run header "id")) + (result (hash-table-ref/default run-test run-id "n/a")) + ;(relative-path (get-relative-path)) + (status (if (string? result) + result + (car result))) + (link (if (string? result) + result + (if (equal? flag #t) + (s:a (car result) 'href (conc "./test_log?runid=" run-id "&testname=" item-name )) + (s:a (car result) 'href (string-substitute (conc linktree "/") "" (cadr result) "-")))))) + (s:td link 'class status))) + runs)))) + res)) + item-keys))) + test-list)))))) + +;; (tests:create-html-tree "test-index.html") +;; +(define (tests:create-html-tree outf) + (let* ((lockfile (conc outf ".lock")) + (runs-to-process '()) + (linktree (common:get-linktree)) + (area-name (common:get-testsuite-name)) + (keys (rmt:get-keys)) + (numkeys (length keys)) + (run-patt (or (args:get-arg "-run-patt") + (args:get-arg "-runname") + "%")) + (target (or (args:get-arg "-target-patt") + (args:get-arg "-target") + "%")) + (targlist (string-split target "/")) + (numtarg (length targlist)) + (targtweaked (if (> numkeys numtarg) + (append targlist (make-list (- numkeys numtarg) "%")) + targlist)) + (target-patt (string-join targtweaked "/")) + ;(total-runs (rmt:get-num-runs "%")) ;;this needs to be changed to filter by target + (total-runs (rmt:get-runs-cnt-by-patt run-patt target-patt keys )) + (pg-size 10)) + (if (common:simple-file-lock lockfile) + (begin + ;(print total-runs) + (let loop ((page 0)) + (let* ((oup (open-output-file (or outf (conc linktree "/page" page ".html")))) + (get-prev-links (lambda (page linktree ) + (let* ((link (if (not (eq? page 0)) + (s:a "<<prev" 'href (conc "page" (- page 1) ".html")) + (s:a "" 'href (conc "page" page ".html"))))) + link))) + (get-next-links (lambda (page linktree total-runs) + (let* ((link (if (> total-runs (+ 10 (* page pg-size))) + (s:a "next>>" 'href (conc "page" (+ page 1) ".html")) + (s:a "" 'href (conc "page" page ".html"))))) + link))) ) + (print "total runs: " total-runs) + (s:output-new + oup + (tests:dashboard-body page pg-size keys numkeys total-runs linktree area-name get-prev-links get-next-links #f run-patt target-patt)) ;; update this function + (close-output-port oup) + ; (set! page (+ 1 page)) + (if (> total-runs (* (+ 1 page) pg-size)) + (loop (+ 1 page))))) + (common:simple-file-release-lock lockfile)) + (begin + (debug-print 0 *default-log-port* "Failed to get lock on file outf, lockfile: " lockfile) #f)))) + + +(define (tests:readlines filename) + (call-with-input-file filename + (lambda (p) + (let loop ((line (read-line p)) + (result '())) + (if (eof-object? line) + (reverse result) + (loop (read-line p) (cons line result))))))) + +(define (tests:get-test-log run-id test-name item-name) + (let* ((test-data (rmt:get-tests-for-run + (string->number run-id) + test-name ;; testnamepatt + '() ;; states + '() ;; statuses + #f ;; offset + #f ;; num-to-get + #f ;; hide/not-hide + #f ;; sort-by + #f ;; sort-order + #f ;; 'shortlist ;; qrytype + 0 ;; last update + #f)) + (path "") + (found 0)) + (debug:print-info 0 *default-log-port* "found: " found ) + + (let loop ((hed (car test-data)) + (tal (cdr test-data))) + (debug:print-info 0 *default-log-port* "item: " (vector-ref hed 11) (vector-ref hed 10) "/" (vector-ref hed 13)) + + (if (equal? (vector-ref hed 11) item-name) + (begin + (set! found 1) + (set! path (conc (vector-ref hed 10) "/" (vector-ref hed 13))))) + (if (and (not (null? tal)) (equal? found 0)) + (loop (car tal)(cdr tal)))) + (if (equal? path "") + "

Data not found

" + (string-join (tests:readlines path) "\n")))) + + +(define (tests:dynamic-dboard page) +;(define (tests:create-html-tree o) + (let* ( +;(page "1") + (linktree (common:get-linktree)) + (area-name (common:get-testsuite-name)) + (keys (rmt:get-keys)) + (numkeys (length keys)) + (targtweaked (make-list numkeys "%")) + (target-patt (string-join targtweaked "/")) + (total-runs (rmt:get-num-runs "%")) + (pg-size 10) + (pg (if (equal? page #f) + 0 + (- (string->number page) 1))) + (get-prev-links (lambda (pg linktree) + (debug:print-info 0 *default-log-port* "val: " (- 1 pg)) + (let* ((link (if (not (eq? pg 0)) + (s:a "<<prev " 'href (conc "dashboard?page=" pg )) + (s:a "" 'href (conc "dashboard?page=" pg))))) + link))) + (get-next-links (lambda (pg linktree total-runs) + (debug:print-info 0 *default-log-port* "val: " pg) + (debug:print-info 0 *default-log-port* "val: " total-runs " size" pg-size) + + (let* ((link (if (> total-runs (+ 10 (* pg pg-size))) + (s:a "next>> " 'href (conc "dashboard?page=" (+ pg 2) )) + (s:a "" 'href (conc "dashboard?page=" pg ))))) + link))) + (html-body (tests:dashboard-body pg pg-size keys numkeys total-runs linktree area-name get-prev-links get-next-links #t "%" target-patt))) ;; update tis function + html-body)) + +(define (tests:create-html-summary outf) + (let* ((lockfile (conc outf ".lock")) + (linktree (common:get-linktree)) + (keys (rmt:get-keys)) + (area-name (common:get-testsuite-name)) + (run-patt (or (args:get-arg "-run-patt") + (args:get-arg "-runname") + "%")) + (target (or (args:get-arg "-target-patt") + (args:get-arg "-target") + "%")) + (targlist (string-split target "/")) + (numkeys (length keys)) + (numtarg (length targlist)) + (targtweaked (if (> numkeys numtarg) + (append targlist (make-list (- numkeys numtarg) "%")) + targlist)) + (target-patt (string-join targtweaked "/"))) + (if (common:simple-file-lock lockfile) + (begin + (let* (;(runsdat1 (rmt:get-runs run-patt #f #f (map (lambda (x)(list x "%")) keys))) + (runsdat (rmt:get-runs-by-patt keys run-patt target-patt #f #f #f 0)) + (runs (vector-ref runsdat 1)) + (header (vector-ref runsdat 0)) + (oup (open-output-file (or outf (conc linktree "/targets.html")))) + (target-hash (test:create-target-hash runs header (length keys)))) + (test:create-target-html target-hash oup area-name linktree) + (test:create-run-html runs area-name linktree (length keys) header)) + (common:simple-file-release-lock lockfile)) + #f))) + +(define (test:get-test-hash test-data) + (let ((resh (make-hash-table))) + (map (lambda (test) + (let* ((test-name (vector-ref test 2)) + (test-html-path (if (file-exists? (conc (vector-ref test 10) "/test-summary.html")) + (conc (vector-ref test 10) "/test-summary.html" ) + (conc (vector-ref test 10) "/" (vector-ref test 13)))) + (test-item (vector-ref test 11)) + (test-status (vector-ref test 4))) + (if (not (hash-table-ref/default resh test-item #f)) + (hash-table-set! resh test-item (make-hash-table))) + (hash-table-set! (hash-table-ref/default resh test-item #f) test-name (list test-status test-html-path)))) + test-data) +resh)) + +(define (test:get-data->b-keys ordered-data a-keys) + (delete-duplicates + (sort (apply + append + (map (lambda (sub-key) + (let ((subdat (hash-table-ref ordered-data sub-key))) + (hash-table-keys subdat))) + a-keys)) + string>=?))) + + +(define (test:create-run-html runs area-name linktree numkeys header) + (map (lambda (run) + (let* ((target (string-join (take (vector->list run) numkeys) "/")) + (run-name (db:get-value-by-header run header "runname")) + (run-time (seconds->work-week/day-time (db:get-value-by-header run header "event_time"))) + (oup (if (file-exists? (conc linktree "/" target "/" run-name)) + (open-output-file (conc linktree "/" target "/" run-name "/run.html")) + #f)) + (run-id (db:get-value-by-header run header "id")) + (test-data (rmt:get-tests-for-run + run-id + "%" ;; testnamepatt + '() ;; states + '() ;; statuses + #f ;; offset + #f ;; num-to-get + #f ;; hide/not-hide + #f ;; sort-by + #f ;; sort-order + #f ;; 'shortlist ;; qrytype + 0 ;; last update + #f)) + (item-test-hash (test:get-test-hash test-data)) + (items (hash-table-keys item-test-hash)) + (test-names (test:get-data->b-keys item-test-hash items))) + (if oup + (begin + (s:output-new + oup + (s:html tests:css-jscript-block (tests:css-jscript-block-cond #f) + (s:title "Runs View " run-name) + (s:body + (s:h1 "Runs View " ) + (s:h3 "Target" target) + (s:p + (s:b "Run name" ) run-name) + (s:p + (s:b "Run Date" ) run-time) + (s:table 'border 1 'cellspacing 0 + (s:tr + (s:th "Items") + (map (lambda (test) + (s:th test)) + test-names)) + (map (lambda (item) + (let* ((test-hash (hash-table-ref/default item-test-hash item #f))) + (if test-hash + (begin + (s:tr + (s:td 'class "test" item) + (map (lambda (test) + (let* ((test-details (hash-table-ref/default test-hash test #f)) + (status (if test-details + (car test-details))) + (link (if test-details + (string-substitute (conc linktree "/" target "/" run-name "/") "" (cadr test-details) "-")))) + (if test-details + (s:td 'class status + (s:a 'class "link" 'href link status )) + (s:td "")))) + test-names)))))) + (sort items string<=?)))))) + (close-output-port oup)) + (debug:print-info 0 "Skip: Dirctory structure " linktree "/" target "/" run-name " does not exist. Megatest will not create run.html")))) +runs)) + +(define (test:create-target-hash runs header numkeys) + (let ((resh (make-hash-table))) + (for-each + (lambda (run) + (let* ((run-name (db:get-value-by-header run header "runname")) + (target (string-join (take (vector->list run) numkeys) "/")) + (run-list (hash-table-ref/default resh target #f))) + + (if (not run-list) + (hash-table-set! resh target (list run-name)) + (hash-table-set! resh target (cons run-name run-list))))) + runs) + resh)) + +(define (test:get-max-run-cnt target-hash targets) + (let* ((cnt 0 )) + (map (lambda (target) + (let* ((runs (hash-table-ref/default target-hash target #f)) + (run-length (if runs + (length runs) + 0))) + + (if (< cnt run-length) + (set! cnt run-length)))) + targets) +cnt)) + +(define (test:pad-runs target-hash targets max-row-length) + (map (lambda (target) + (let loop ((run-list (hash-table-ref/default target-hash target #f))) + (if (< (length run-list) max-row-length) + (begin + (hash-table-set! target-hash target (cons "" run-list)) + (loop (hash-table-ref/default target-hash target #f) ))))) + targets) + target-hash) + +(define (test:create-target-html target-hash oup area-name linktree) + (let* ((targets (hash-table-keys target-hash)) + (max-row-length (test:get-max-run-cnt target-hash targets)) + (pad-runs-hash (test:pad-runs target-hash targets max-row-length))) + (s:output-new + oup + (s:html tests:css-jscript-block (tests:css-jscript-block-cond #f) + + (s:title "Target View " area-name) + (s:body + (s:h1 "Target View " area-name) + (s:table 'id "LinkedList1" 'border "1" 'cellspacing 0 + (s:tr 'class "something" + (s:th "Target") + (s:th 'colspan max-row-length "Runs")) + (let* ((tbl (map (lambda (target) + (s:tr + (s:td 'class "test" target) + (let* ((runs (hash-table-ref/default target-hash target #f)) + (rest-row (map (lambda (run) + (if (equal? run "") + (s:td run) + (if (file-exists?(conc linktree "/" target "/" run )) + (begin + (s:td + (s:a 'href (conc target "/" run "/run.html") run)))))) + (reverse runs)))) + rest-row))) + targets))) + tbl))))) + (close-output-port oup))) + + +(define (tests:create-html-tree-old outf) + (let* ((lockfile (conc outf ".lock")) + (runs-to-process '())) + (if (common:simple-file-lock lockfile) + (let* ((linktree (common:get-linktree)) + (oup (open-output-file (or outf (conc linktree "/runs-index.html")))) + (area-name (common:get-testsuite-name)) + (keys (rmt:get-keys)) + (numkeys (length keys)) + (runsdat (rmt:get-runs "%" #f #f (map (lambda (x)(list x "%")) keys))) + (header (vector-ref runsdat 0)) + (runs (vector-ref runsdat 1)) + (runtreedat (map (lambda (x) + (tests:run-record->test-path x numkeys)) + runs)) + (runs-htree (common:list->htree runtreedat))) + (set! runs-to-process runs) + (s:output-new + oup + (s:html tests:css-jscript-block + (s:title "Summary for " area-name) + (s:body 'onload "addEvents();" + (s:h1 "Summary for " area-name) + ;; top list + (s:ul 'id "LinkedList1" 'class "LinkedList" + (s:li + "Runs" + (common:htree->html runs-htree + '() + (lambda (x p) + (let* ((targ-path (string-intersperse p "/")) + (full-path (conc linktree "/" targ-path)) + (run-name (car (reverse p)))) + (if (and (common:file-exists? full-path) + (directory? full-path) + (file-write-access? full-path)) + (s:a run-name 'href (conc targ-path "/run-summary.html")) + (begin + (debug:print 0 *default-log-port* "INFO: Can't create " targ-path "/run-summary.html") + (conc run-name " (Not able to create summary at " targ-path ")"))))))))))) + (close-output-port oup) + (common:simple-file-release-lock lockfile) + + (for-each + (lambda (run) + (let* ((test-subpath (tests:run-record->test-path run numkeys)) + (run-id (db:get-value-by-header run header "id")) + (run-dir (tests:run-record->test-path run numkeys)) + (test-dats (rmt:get-tests-for-run + run-id + "%/" ;; testnamepatt + '() ;; states + '() ;; statuses + #f ;; offset + #f ;; num-to-get + #f ;; hide/not-hide + #f ;; sort-by + #f ;; sort-order + #f ;; 'shortlist ;; qrytype + 0 ;; last update + #f)) + (tests-tree-dat (map (lambda (test-dat) + ;; (tests:run-record->test-path x numkeys)) + (let* ((test-name (db:test-get-testname test-dat)) + (item-path (db:test-get-item-path test-dat)) + (full-name (db:test-make-full-name test-name item-path)) + (path-parts (string-split full-name))) + path-parts)) + test-dats)) + (tests-htree (common:list->htree tests-tree-dat)) + (html-dir (conc linktree "/" (string-intersperse run-dir "/"))) + (html-path (conc html-dir "/run-summary.html")) + (oup (if (and (common:file-exists? html-dir) + (directory? html-dir) + (file-write-access? html-dir)) + (open-output-file html-path) + #f))) + ;; (print "run-dir: " run-dir ", tests-tree-dat: " tests-tree-dat) + (if oup + (begin + (s:output-new + oup + (s:html tests:css-jscript-block + (s:title "Summary for " area-name) + (s:body 'onload "addEvents();" + (s:h1 "Summary for " (string-intersperse run-dir "/")) + ;; top list + (s:ul 'id "LinkedList1" 'class "LinkedList" + (s:li + "Tests" + (common:htree->html tests-htree + '() + (lambda (x p) + (let* ((targ-path (string-intersperse p "/")) + (test-name (car p)) + (item-path ;; (if (> (length p) 2) ;; test-name + run-name + (string-intersperse p "/")) + (full-targ (conc html-dir "/" targ-path)) + (std-file (conc full-targ "/test-summary.html")) + (alt-file (conc full-targ "/megatest-rollup-" test-name ".html")) + (html-file (if (common:file-exists? alt-file) + alt-file + std-file)) + (run-name (car (reverse p)))) + (if (and (not (common:file-exists? full-targ)) + (directory? full-targ) + (file-write-access? full-targ)) + (tests:summarize-test + run-id + (rmt:get-test-id run-id test-name item-path))) + (if (common:file-exists? full-targ) + (s:a run-name 'href html-file) + (begin + (debug:print 0 *default-log-port* "ERROR: can't access " full-targ) + (conc "No summary for " run-name))))) + )))))) + (close-output-port oup))))) + runs) + #t) + #f))) + + + + + + ;; CHECK - WAS THIS ADDED OR REMOVED? MANUAL MERGE WITH API STUFF!!! ;; ;; get a pretty table to summarize steps ;; @@ -582,19 +1320,21 @@ (for-each (lambda (step) (debug:print 6 *default-log-port* "step=" step) (let ((record (hash-table-ref/default res - (tdb:step-get-stepname step) - ;; stepname start end status Duration Logfile Comment - (vector (tdb:step-get-stepname step) "" "" "" "" "" "")))) + (tdb:step-get-stepname step) + ;; 0 1 2 3 4 5 6 7 + ;; stepname start end status Duration Logfile Comment first-id + (vector (tdb:step-get-stepname step) "" "" "" "" "" "" #f)))) (debug:print 6 *default-log-port* "record(before) = " record "\nid: " (tdb:step-get-id step) "\nstepname: " (tdb:step-get-stepname step) "\nstate: " (tdb:step-get-state step) "\nstatus: " (tdb:step-get-status step) "\ntime: " (tdb:step-get-event_time step)) + (if (not (vector-ref record 7))(vector-set! record 7 (tdb:step-get-id step))) ;; do not clobber the id if previously set (case (string->symbol (tdb:step-get-state step)) ((start)(vector-set! record 1 (tdb:step-get-event_time step)) (vector-set! record 3 (if (equal? (vector-ref record 3) "") (tdb:step-get-status step))) (if (> (string-length (tdb:step-get-logfile step)) @@ -638,107 +1378,144 @@ res)) ;; ;; (define (tests:get-compressed-steps run-id test-id) - (let* ((steps-data (rmt:get-steps-for-test run-id test-id)) - (comprsteps (tests:process-steps-table steps-data))) ;; (open-run-close db:get-steps-table #f test-id work-area: work-area))) + (let* ((steps-data (rmt:get-steps-for-test run-id test-id)) ;; 0 1 2 3 4 5 6 7 + (comprsteps (tests:process-steps-table steps-data))) ;; # (map (lambda (x) ;; take advantage of the \n on time->string - (vector - (vector-ref x 0) + (vector ;; we are constructing basically the original vector but collapsing start end records + (vector-ref x 0) ;; id 0 (let ((s (vector-ref x 1))) - (if (number? s)(seconds->time-string s) s)) + (if (number? s)(seconds->time-string s) s)) ;; starttime 1 (let ((s (vector-ref x 2))) - (if (number? s)(seconds->time-string s) s)) - (vector-ref x 3) ;; status - (vector-ref x 4) - (vector-ref x 5) ;; time delta - (vector-ref x 6))) + (if (number? s)(seconds->time-string s) s)) ;; endtime 2 + (vector-ref x 3) ;; status 3 + (vector-ref x 4) ;; duration 4 + (vector-ref x 5) ;; logfile 5 + (vector-ref x 6) ;; comment 6 + (vector-ref x 7))) ;; id 7 (sort (hash-table-values comprsteps) (lambda (a b) (let ((time-a (vector-ref a 1)) - (time-b (vector-ref b 1))) + (time-b (vector-ref b 1)) + (id-a (vector-ref a 7)) + (id-b (vector-ref b 7))) (if (and (number? time-a)(number? time-b)) (if (< time-a time-b) #t (if (eq? time-a time-b) - (stringwork-week/day-time - (db:test-get-event_time test-dat))) - (s:td "Duration") (s:td (seconds->hr-min-sec (db:test-get-run_duration test-dat))))) - (s:h3 "Log files") - (s:table - 'cellspacing "0" 'border "1" - (s:tr (s:td "Final log")(s:td (s:a 'href logf logf)))) - (s:table - 'cellspacing "0" 'border "1" - (s:tr (s:td "Step Name")(s:td "Start")(s:td "End")(s:td "Status")(s:td "Duration")(s:td "Log File")) - (map (lambda (step-dat) - (s:tr (s:td (tdb:steps-table-get-stepname step-dat)) - (s:td (tdb:steps-table-get-start step-dat)) - (s:td (tdb:steps-table-get-end step-dat)) - (s:td (tdb:steps-table-get-status step-dat)) - (s:td (tdb:steps-table-get-runtime step-dat)) - (s:td (let ((step-log (tdb:steps-table-get-log-file step-dat))) - (s:a 'href step-log step-log))))) - steps-dat)) - ))) - (close-output-port oup))) + (out-dir (db:test-get-rundir test-dat)) + (out-file (conc out-dir "/test-summary.html"))) + ;; first verify we are able to write the output file + (if (not (file-write-access? out-dir)) + (debug:print 0 *default-log-port* "ERROR: cannot write test-summary.html to " out-dir) + (let* (;; (steps-dat (rmt:get-steps-for-test run-id test-id)) + (test-name (db:test-get-testname test-dat)) + (item-path (db:test-get-item-path test-dat)) + (full-name (db:test-make-full-name test-name item-path)) + (oup (open-output-file out-file)) + (status (db:test-get-status test-dat)) + (color (common:get-color-from-status status)) + (logf (db:test-get-final_logf test-dat)) + (steps-dat (tests:get-compressed-steps run-id test-id))) + ;; (dcommon:get-compressed-steps #f 1 30045) + ;; (#("wasting_time" "23:36:13" "23:36:21" "0" "8.0s" "wasting_time.log")) + + (s:output-new + oup + (s:html + (s:title "Summary for " full-name) + (s:body + (s:h2 "Summary for " full-name) + (s:table 'cellspacing "0" 'border "1" + (s:tr (s:td "run id") (s:td (db:test-get-run_id test-dat)) + (s:td "test id") (s:td (db:test-get-id test-dat))) + (s:tr (s:td "testname") (s:td test-name) + (s:td "itempath") (s:td item-path)) + (s:tr (s:td "state") (s:td (db:test-get-state test-dat)) + (s:td "status") (s:td (s:a 'href logf (s:font 'color color status)))) + (s:tr (s:td "TestDate") (s:td (seconds->work-week/day-time + (db:test-get-event_time test-dat))) + (s:td "Duration") (s:td (seconds->hr-min-sec (db:test-get-run_duration test-dat))))) + (s:h3 "Log files") + (s:table + 'cellspacing "0" 'border "1" + (s:tr (s:td "Final log")(s:td (s:a 'href logf logf)))) + (s:table + 'cellspacing "0" 'border "1" + (s:tr (s:td "Step Name")(s:td "Start")(s:td "End")(s:td "Status")(s:td "Duration")(s:td "Log File")) + (map (lambda (step-dat) + (s:tr (s:td (tdb:steps-table-get-stepname step-dat)) + (s:td (tdb:steps-table-get-start step-dat)) + (s:td (tdb:steps-table-get-end step-dat)) + (s:td (tdb:steps-table-get-status step-dat)) + (s:td (tdb:steps-table-get-runtime step-dat)) + (s:td (let ((step-log (tdb:steps-table-get-log-file step-dat))) + (s:a 'href step-log step-log))))) + steps-dat)) + ))) + (close-output-port oup))))) ;; MUST BE CALLED local! ;; (define (tests:test-get-paths-matching keynames target fnamepatt #!key (res '())) ;; BUG: Move the values derived from args to parameters and push to megatest.scm - (let* ((testpatt (if (args:get-arg "-testpatt")(args:get-arg "-testpatt") "%")) - (statepatt (if (args:get-arg ":state") (args:get-arg ":state") "%")) - (statuspatt (if (args:get-arg ":status") (args:get-arg ":status") "%")) - (runname (if (args:get-arg ":runname") (args:get-arg ":runname") "%")) + (let* ((testpatt (or (args:get-arg "-testpatt")(args:get-arg "-testpatt") "%")) + (statepatt (or (args:get-arg "-state") (args:get-arg ":state") "%")) + (statuspatt (or (args:get-arg "-status") (args:get-arg ":status") "%")) + (runname (or (args:get-arg "-runname") (args:get-arg ":runname") "%")) (paths-from-db (rmt:test-get-paths-matching-keynames-target-new keynames target res testpatt statepatt statuspatt runname))) (if fnamepatt (apply append (map (lambda (p) (if (directory-exists? p) - (glob (conc p "/" fnamepatt)) + (let ((glob-query (conc p "/" fnamepatt))) + (handle-exceptions + exn + (begin + (print "built-in glob on " glob-query ", failed, try using the shell. exn=" exn) + (with-input-from-pipe + (conc "echo " glob-query) + read-lines)) ;; we aren't going to try too hard. If glob breaks it is likely because someone tried to do */*/*.log or similar + (glob glob-query))) '())) paths-from-db)) paths-from-db))) @@ -746,11 +1523,11 @@ ;; Gather data from test/task specifications ;;====================================================================== ;; (define (tests:get-valid-tests testsdir test-patts) ;; #!key (test-names '())) ;; (let ((tests (glob (conc testsdir "/tests/*")))) ;; " (string-translate patt "%" "*"))))) -;; (set! tests (filter (lambda (test)(file-exists? (conc test "/testconfig"))) tests)) +;; (set! tests (filter (lambda (test)(common:file-exists? (conc test "/testconfig"))) tests)) ;; (delete-duplicates ;; (filter (lambda (testname) ;; (tests:match test-patts testname #f)) ;; (map (lambda (testp) ;; (last (string-split testp "/"))) @@ -763,135 +1540,188 @@ (getenv "MT_TEST_NAME") (getenv "MT_ITEMPATH")) (conc (getenv "MT_LINKTREE") "/" (getenv "MT_TARGET") "/" (getenv "MT_RUNNAME") "/" - (getenv "MT_TEST_NAME") "/" - (if (or (getenv "MT_ITEMPATH") - (not (string=? "" (getenv "MT_ITEMPATH")))) - (conc "/" (getenv "MT_ITEMPATH")))) + (getenv "MT_TEST_NAME") + (if (and (getenv "MT_ITEMPATH") + (not (string=? "" (getenv "MT_ITEMPATH")))) + (conc "/" (getenv "MT_ITEMPATH")) + "")) #f)) ;; if .testconfig exists in test directory read and return it ;; else if have cached copy in *testconfigs* return it IFF there is a section "have fulldata" ;; else read the testconfig file ;; if have path to test directory save the config as .testconfig and return it ;; -(define (tests:get-testconfig test-name test-registry system-allowed #!key (force-create #f)) - (let* ((cache-path (tests:get-test-path-from-environment)) +(define (tests:get-testconfig test-name item-path test-registry system-allowed #!key (force-create #f)(allow-write-cache #t)(wait-a-minute #f)) + (let* ((use-cache (common:use-cache?)) + (cache-path (tests:get-test-path-from-environment)) (cache-file (and cache-path (conc cache-path "/.testconfig"))) (cache-exists (and cache-file (not force-create) ;; if force-create then pretend there is no cache to read - (file-exists? cache-file))) + (common:file-exists? cache-file))) (cached-dat (if (and (not force-create) - cache-exists) + cache-exists + use-cache) (handle-exceptions - exn - #f ;; any issues, just give up with the cached version and re-read - (configf:read-alist cache-file)) - #f))) + exn + (begin + (debug:print 0 *default-log-port* "failed to read " cache-file ", exn=" exn) + #f) ;; any issues, just give up with the cached version and re-read + (configf:read-alist cache-file)) + #f)) + (test-full-name (if (and item-path (not (string-null? item-path))) + (conc test-name "/" item-path) + test-name))) (if cached-dat cached-dat - (let ((dat (hash-table-ref/default *testconfigs* test-name #f))) + (let ((dat (hash-table-ref/default *testconfigs* test-full-name #f))) (if (and dat ;; have a locally cached version (hash-table-ref/default dat "have fulldata" #f)) ;; marked as good data? dat ;; no cached data available (let* ((treg (or test-registry (tests:get-all))) (test-path (or (hash-table-ref/default treg test-name #f) + (let* ((local-tcdir (conc (getenv "MT_LINKTREE") "/" + (getenv "MT_TARGET") "/" + (getenv "MT_RUNNAME") "/" + test-name "/" item-path)) + (local-tcfg (conc local-tcdir "/testconfig"))) + (if (common:file-exists? local-tcfg) + local-tcdir + #f)) (conc *toppath* "/tests/" test-name))) (test-configf (conc test-path "/testconfig")) - (testexists (and (file-exists? test-configf)(file-read-access? test-configf))) + (testexists (let loopa ((tries-left 30)) + (cond + ( + (and (common:file-exists? test-configf)(file-read-access? test-configf)) + #t) + ( + (common:file-exists? test-configf) + (debug:print 0 *default-log-port* "WARNING: Cannot read testconfig file: "test-configf) + #f) + ( + (and wait-a-minute (> tries-left 0)) + (thread-sleep! 10) + (debug:print 0 *default-log-port* "WARNING: testconfig file does not exist: "test-configf" will retry in 10 seconds. Tries left: "tries-left) ;; BB: this fires + (loopa (sub1 tries-left))) + (else + (debug:print 0 *default-log-port* "WARNING: testconfig file does not exist: "test-configf) ;; BB: this fires + #f)))) (tcfg (if testexists (read-config test-configf #f system-allowed environ-patt: (if system-allowed "pre-launch-env-vars" #f)) #f))) (if (and tcfg cache-file) (hash-table-set! tcfg "have fulldata" #t)) ;; mark this as fully read data - (if tcfg (hash-table-set! *testconfigs* test-name tcfg)) + (if tcfg (hash-table-set! *testconfigs* test-full-name tcfg)) (if (and testexists cache-file - (file-write-access? cache-path)) + (file-write-access? cache-path) + allow-write-cache) (let ((tpath (conc cache-path "/.testconfig"))) (debug:print-info 1 *default-log-port* "Caching testconfig for " test-name " in " tpath) - (configf:write-alist tcfg tpath))) + (if (and tcfg (not (common:in-running-test?))) + (configf:write-alist tcfg tpath)))) tcfg)))))) ;; sort tests by priority and waiton ;; Move test specific stuff to a test unit FIXME one of these days (define (tests:sort-by-priority-and-waiton test-records) - (let* ((mungepriority (lambda (priority) - (if priority - (let ((tmp (any->number priority))) - (if tmp tmp (begin (debug:print-error 0 *default-log-port* "bad priority value " priority ", using 0") 0))) - 0))) - (all-tests (hash-table-keys test-records)) - (all-waited-on (let loop ((hed (car all-tests)) - (tal (cdr all-tests)) - (res '())) - (let* ((trec (hash-table-ref test-records hed)) - (waitons (or (tests:testqueue-get-waitons trec) '()))) - (if (null? tal) - (append res waitons) - (loop (car tal)(cdr tal)(append res waitons)))))) - (sort-fn1 - (lambda (a b) - (let* ((a-record (hash-table-ref test-records a)) - (b-record (hash-table-ref test-records b)) - (a-waitons (or (tests:testqueue-get-waitons a-record) '())) - (b-waitons (or (tests:testqueue-get-waitons b-record) '())) - (a-config (tests:testqueue-get-testconfig a-record)) - (b-config (tests:testqueue-get-testconfig b-record)) - (a-raw-pri (config-lookup a-config "requirements" "priority")) - (b-raw-pri (config-lookup b-config "requirements" "priority")) - (a-priority (mungepriority a-raw-pri)) - (b-priority (mungepriority b-raw-pri))) - (tests:testqueue-set-priority! a-record a-priority) - (tests:testqueue-set-priority! b-record b-priority) - ;; (debug:print 0 *default-log-port* "a=" a ", b=" b ", a-waitons=" a-waitons ", b-waitons=" b-waitons) - (cond - ;; is - ((member a b-waitons) ;; is b waiting on a? - ;; (debug:print 0 *default-log-port* "case1") - #t) - ((member b a-waitons) ;; is a waiting on b? - ;; (debug:print 0 *default-log-port* "case2") - #f) - ((and (not (null? a-waitons)) ;; both have waitons - do not disturb - (not (null? b-waitons))) - ;; (debug:print 0 *default-log-port* "case2.1") - #t) - ((and (null? a-waitons) ;; no waitons for a but b has waitons - (not (null? b-waitons))) - ;; (debug:print 0 *default-log-port* "case3") - #f) - ((and (not (null? a-waitons)) ;; a has waitons but b does not - (null? b-waitons)) - ;; (debug:print 0 *default-log-port* "case4") - #t) - ((not (eq? a-priority b-priority)) ;; use - (> a-priority b-priority)) - (else - ;; (debug:print 0 *default-log-port* "case5") - (string>? a b)))))) - - (sort-fn2 - (lambda (a b) - (> (mungepriority (tests:testqueue-get-priority (hash-table-ref test-records a))) - (mungepriority (tests:testqueue-get-priority (hash-table-ref test-records b))))))) - ;; (let ((dot-res (tests:run-dot (tests:tests->dot test-records) "plain"))) - ;; (debug:print "dot-res=" dot-res)) - ;; (let ((data (map cdr (filter - ;; (lambda (x)(equal? "node" (car x))) - ;; (map string-split (tests:easy-dot test-records "plain")))))) - ;; (map car (sort data (lambda (a b) - ;; (> (string->number (caddr a))(string->number (caddr b))))))) - ;; )) - (sort all-tests sort-fn1))) ;; avoid dealing with deleted tests, look at the hash table - + (if (eq? (hash-table-size test-records) 0) + '() + (let* ((mungepriority (lambda (priority) + (if priority + (let ((tmp (any->number priority))) + (if tmp tmp (begin (debug:print-error 0 *default-log-port* "bad priority value " priority ", using 0") 0))) + 0))) + (all-tests (hash-table-keys test-records)) + (all-waited-on (let loop ((hed (car all-tests)) + (tal (cdr all-tests)) + (res '())) + (let* ((trec (hash-table-ref test-records hed)) + (waitons (or (tests:testqueue-get-waitons trec) '()))) + (if (null? tal) + (append res waitons) + (loop (car tal)(cdr tal)(append res waitons)))))) + (sort-fn1 + (lambda (a b) + (let* ((a-record (hash-table-ref test-records a)) + (b-record (hash-table-ref test-records b)) + (a-waitons (or (tests:testqueue-get-waitons a-record) '())) + (b-waitons (or (tests:testqueue-get-waitons b-record) '())) + (a-config (tests:testqueue-get-testconfig a-record)) + (b-config (tests:testqueue-get-testconfig b-record)) + (a-raw-pri (configf:lookup a-config "requirements" "priority")) + (b-raw-pri (configf:lookup b-config "requirements" "priority")) + (a-priority (mungepriority a-raw-pri)) + (b-priority (mungepriority b-raw-pri))) + (tests:testqueue-set-priority! a-record a-priority) + (tests:testqueue-set-priority! b-record b-priority) + ;; (debug:print 0 *default-log-port* "a=" a ", b=" b ", a-waitons=" a-waitons ", b-waitons=" b-waitons) + (cond + ;; is + ((member a b-waitons) ;; is b waiting on a? + ;; (debug:print 0 *default-log-port* "case1") + #t) + ((member b a-waitons) ;; is a waiting on b? + ;; (debug:print 0 *default-log-port* "case2") + #f) + ((and (not (null? a-waitons)) ;; both have waitons - do not disturb + (not (null? b-waitons))) + ;; (debug:print 0 *default-log-port* "case2.1") + #t) + ((and (null? a-waitons) ;; no waitons for a but b has waitons + (not (null? b-waitons))) + ;; (debug:print 0 *default-log-port* "case3") + #f) + ((and (not (null? a-waitons)) ;; a has waitons but b does not + (null? b-waitons)) + ;; (debug:print 0 *default-log-port* "case4") + #t) + ((not (eq? a-priority b-priority)) ;; use + (> a-priority b-priority)) + (else + ;; (debug:print 0 *default-log-port* "case5") + (string>? a b)))))) + + (sort-fn2 + (lambda (a b) + (> (mungepriority (tests:testqueue-get-priority (hash-table-ref test-records a))) + (mungepriority (tests:testqueue-get-priority (hash-table-ref test-records b))))))) + ;; (let ((dot-res (tests:run-dot (tests:tests->dot test-records) "plain"))) + ;; (debug:print "dot-res=" dot-res)) + ;; (let ((data (map cdr (filter + ;; (lambda (x)(equal? "node" (car x))) + ;; (map string-split (tests:easy-dot test-records "plain")))))) + ;; (map car (sort data (lambda (a b) + ;; (> (string->number (caddr a))(string->number (caddr b))))))) + ;; )) + (sort all-tests sort-fn1)))) ;; avoid dealing with deleted tests, look at the hash table + +;; look up all waitons that are related to test "testname" +;; +(define (tests:get-mt-waitons testname flatten) + (let* ((mt-waitons (configf:get-section *configdat* "waitons")) + (my-waitons (filter + (lambda (x) + (string-match (conc "^(" testname "|" testname"/.*)$") (car x))) + mt-waitons))) + (if flatten + (map (lambda (w) + (car (string-split w "/"))) + (apply append (map (lambda (x) + (string-split (cadr x))) + my-waitons))) + my-waitons))) + +;; NOT USED (define (tests:easy-dot test-records outtype) (let-values (((fd temp-path) (file-mkstemp (conc "/tmp/" (current-user-name) ".XXXXXX")))) (let ((all-testnames (hash-table-keys test-records)) (temp-port (open-output-file* fd))) ;; (format temp-port "This file is ~A.~%" temp-path) @@ -899,15 +1729,17 @@ (format temp-port " size=4,8\n") ;; (format temp-port " splines=none\n") (for-each (lambda (testname) (let* ((testrec (hash-table-ref test-records testname)) - (waitons (or (tests:testqueue-get-waitons testrec) '()))) + (waitons (or (tests:testqueue-get-waitons testrec) '())) + (my-mt-waitons (tests:get-mt-waitons testname #t))) + ;; (print "my-mt-waitons=" my-mt-waitons) (for-each (lambda (waiton) (format temp-port (conc " " waiton " -> " testname " [splines=ortho]\n"))) - waitons))) + (append waitons my-mt-waitons)))) all-testnames) (format temp-port "}\n") (close-output-port temp-port) (with-input-from-pipe (conc "env -i PATH=$PATH dot -T" outtype " < " temp-path) @@ -932,17 +1764,19 @@ (conc " size=\"" (or sizex 11) "," (or sizey 11) "\";") " ratio=0.95;" ))) (let* ((testrec (hash-table-ref test-records hed)) (waitons (or (tests:testqueue-get-waitons testrec) '())) + (my-mt-waitons (tests:get-mt-waitons hed #t)) + (all-waitons (delete-duplicates (append waitons my-mt-waitons))) (newres (append res - (if (null? waitons) + (if (null? all-waitons) (list (conc " \"" hed "\" [shape=box];")) (map (lambda (waiton) (conc " \"" waiton "\" -> \"" hed "\" [shape=box];")) - waitons) - )))) + all-waitons))))) + ;; (debug:print 0 *default-log-port* "For test "hed" got "all-waitons) (if (null? tal) (append newres (list "}")) (loop (car tal)(cdr tal) newres) )))))) @@ -960,27 +1794,34 @@ (close-input-port inp) res))) ;; read data from tmp file or create if not exists ;; if exists regen in background +;; mode: raw (return data as read) or munged (convert to list of lists and remove " from strings) ;; -(define (tests:lazy-dot testrecords outtype sizex sizey) +(define (tests:lazy-dot testrecords outtype sizex sizey mode) (let ((dfile (conc "/tmp/." (current-user-name) "-" (server:mk-signature) ".dot")) (fname (conc "/tmp/." (current-user-name) "-" (server:mk-signature) ".dotdat"))) (tests:write-dot-file testrecords dfile sizex sizey) - (if (file-exists? fname) - (let ((res (with-input-from-file fname - (lambda () - (read-lines))))) - (system (conc "env -i PATH=$PATH dot -T " outtype " < " dfile " > " fname "&")) - res) - (begin - (system (conc "env -i PATH=$PATH dot -T " outtype " < " dfile " > " fname)) - (with-input-from-file fname - (lambda () - (read-lines))))))) - + (let ((data (if (common:file-exists? fname) + (let ((res (with-input-from-file fname + (lambda () + (read-lines))))) + (system (conc "env -i PATH=$PATH dot -T " outtype " < " dfile " > " fname "&")) + res) + (begin + (system (conc "env -i PATH=$PATH dot -T " outtype " < " dfile " > " fname)) + (with-input-from-file fname + (lambda () + (read-lines))))))) + (if (eq? mode 'raw) + data + (map (lambda (inl) + (map (lambda (s) + (string-substitute "\"" "" s #t)) + (string-split inl))) + data))))) ;; for each test: ;; (define (tests:filter-non-runnable run-id testkeynames testrecordshash) (let ((runnables '())) @@ -1033,13 +1874,14 @@ (define (tests:get-full-data test-names test-records required-tests all-tests-registry) (if (not (null? test-names)) (let loop ((hed (car test-names)) (tal (cdr test-names))) ;; 'return-procs tells the config reader to prep running system but return a proc (debug:print-info 4 *default-log-port* "hed=" hed " at top of loop") - (let* ((config (tests:get-testconfig hed all-tests-registry 'return-procs)) + ;; don't know item-path at this time, let the testconfig get the top level testconfig + (let* ((config (tests:get-testconfig hed #f all-tests-registry 'return-procs)) (waitons (let ((instr (if config - (config-lookup config "requirements" "waiton") + (configf:lookup config "requirements" "waiton") (begin ;; No config means this is a non-existant test (debug:print-error 0 *default-log-port* "non-existent required test \"" hed "\", grep through your testconfigs to find and remove or create the test. Discarding and continuing.") "")))) (debug:print-info 8 *default-log-port* "waitons string is " instr) (string-split (cond @@ -1068,11 +1910,11 @@ (if (not (hash-table-ref/default test-records hed #f)) (hash-table-set! test-records hed (vector hed ;; 0 config ;; 1 waitons ;; 2 - (config-lookup config "requirements" "priority") ;; priority 3 + (configf:lookup config "requirements" "priority") ;; priority 3 (let ((items (hash-table-ref/default config "items" #f)) ;; items 4 (itemstable (hash-table-ref/default config "itemstable" #f))) ;; if either items or items table is a proc return it so test running ;; process can know to call items:get-items-from-config ;; if either is a list and none is a proc go ahead and call get-items @@ -1130,51 +1972,53 @@ tdb "SELECT count(id) FROM test_rundat;") res)) 0) -(define (tests:update-central-meta-info run-id test-id cpuload diskfree minutes uname hostname) - (if (and cpuload diskfree) - (rmt:general-call 'update-cpuload-diskfree run-id cpuload diskfree test-id)) - (if minutes - (rmt:general-call 'update-run-duration run-id minutes test-id)) - (if (and uname hostname) - (rmt:general-call 'update-uname-host run-id uname hostname test-id))) +;; +(define (tests:update-central-meta-info run-id test-id cpuload diskfree minutes uname hostname #!key (update-db #f)(tmpfree #f)) + (if (get-environment-variable "MT_TEST_RUN_DIR") + (let* ((dest-dir (conc (get-environment-variable "MT_TEST_RUN_DIR") "/.mt_data")) + (or-dash (lambda (instr) + (cond + ((not instr) "") ;; #f -> blank, indicates value unchanged since last measurement taken + ((string? instr)(if (string-search " " instr) (conc "\"" instr "\"") instr)) + (else instr)))) + (file-new (not (directory-exists? dest-dir)))) + (if file-new (create-directory dest-dir #t)) + (let* ((outp (open-output-file (conc dest-dir "/test-run.dat") #:append))) + (with-output-to-port outp + (lambda () + (if file-new + (print "epoch_time,run_id,test_id,cpuload,diskfree,tmpfree,run_minutes,hostname,uname")) + (print (current-seconds) "," (or-dash run-id) "," (or-dash test-id) "," + (or-dash cpuload) "," (or-dash diskfree) "," (or-dash tmpfree) "," + (or-dash minutes) "," (or-dash hostname) "," + (or-dash uname)))) ;; put uname last as it has spaces in it + (close-output-port outp))) + (begin + (rmt:general-call 'update-test-rundat run-id test-id (current-seconds) (or cpuload -1)(or diskfree -1) -1 (or minutes -1)))) + (if update-db + (begin + (if (and cpuload diskfree) + (rmt:general-call 'update-cpuload-diskfree run-id cpuload diskfree test-id)) + (if minutes + (rmt:general-call 'update-run-duration run-id minutes test-id)) + (if (and uname hostname) + (rmt:general-call 'update-uname-host run-id uname hostname test-id))))) ;; This one is for running with no db access (i.e. via rmt: internally) -(define (tests:set-full-meta-info db test-id run-id minutes work-area remtries) +(define (tests:set-full-meta-info db test-id run-id minutes work-area remtries #!key (update-db #f)) ;; (define (tests:set-full-meta-info test-id run-id minutes work-area) ;; (let ((remtries 10)) (let* ((cpuload (get-cpu-load)) (diskfree (get-df (current-directory))) + (tmpfree (get-df "/tmp")) (uname (get-uname "-srvpio")) (hostname (get-host-name))) - (tests:update-central-meta-info run-id test-id cpuload diskfree minutes uname hostname))) - -;; (define (tests:set-partial-meta-info test-id run-id minutes work-area) -(define (tests:set-partial-meta-info test-id run-id minutes work-area remtries) - (let* ((cpuload (get-cpu-load)) - (diskfree (get-df (current-directory))) - (remtries 10)) - (handle-exceptions - exn - (if (> remtries 0) - (begin - (print-call-chain (current-error-port)) - (debug:print-info 0 *default-log-port* "WARNING: failed to set meta info. Will try " remtries " more times") - (set! remtries (- remtries 1)) - (thread-sleep! 10) - (tests:set-full-meta-info db test-id run-id minutes work-area (- remtries 1))) - (let ((err-status ((condition-property-accessor 'sqlite3 'status #f) exn))) - (debug:print-error 0 *default-log-port* "tried for over a minute to update meta info and failed. Giving up") - (debug:print 0 *default-log-port* "EXCEPTION: database probably overloaded or unreadable.") - (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) - (print "exn=" (condition->list exn)) - (debug:print 0 *default-log-port* " status: " ((condition-property-accessor 'sqlite3 'status) exn)) - (print-call-chain (current-error-port)))) - (tests:update-testdat-meta-info db test-id work-area cpuload diskfree minutes) - ))) + (tests:update-central-meta-info run-id test-id cpuload diskfree minutes uname hostname update-db: update-db tmpfree: tmpfree))) + ;;====================================================================== ;; A R C H I V I N G ;;====================================================================== Index: tests/Makefile ================================================================== --- tests/Makefile +++ tests/Makefile @@ -1,10 +1,28 @@ +# Copyright 2006-2017, Matthew Welland. +# +# This file is part of Megatest. +# +# Megatest is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# Megatest is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with Megatest. If not, see . # # run some tests BINPATH = $(shell readlink -m $(PWD)/../bin) +LSBR = $(shell lsb_release -sr) MEGATEST = $(BINPATH)/megatest +MTEST = $(BINPATH)/.$(LSBR)/mtest DASHBOARD = $(BINPATH)/dashboard PATH := $(BINPATH):$(PATH) RUNNAME := $(shell date +w%V.%u.%H.%M) IPADDR := "-" RUNID := 1 @@ -19,21 +37,26 @@ # The NEWTARGET causes some tests to fail. Do not use until this is fixed. NEWTARGET = "$(OS)/$(FS)/$(VER)" TARGET = "ubuntu/nfs/none" -all : build unit test1 test2 test3 test4 test5 test6 test7 test8 test9 +all : build unit test4 +# test1 test2 test3 test4 test5 test6 test7 test8 test9 + +unit : all-rmt.log all-api.log +# basicserver.log runs.log misc.log tests.log -unit : basicserver.log runs.log misc.log tests.log +# inter dependencies on the unit tests, I wish these could be "suggestions" +all-rmt.log : all-api.log rel : cd release;dashboard -rows 25 & ## basicserver.log : unittests/basicserver.scm ## script -c "./rununittest.sh basicserver $(DEBUG)" basicserver.log -%.log : build unittests/%.scm +%.log : build unittests/%.scm $(MTEST) script -c "./rununittest.sh $* $(DEBUG)" $*.log if logpro unit.logpro $*.html < $*.log > /dev/null;then echo ALLPASS;else echo ALLFAIL;mv $*.log $*.log.FAIL;fi server : cd fullrun;$(MEGATEST) -server - -debug $(DEBUG) -run-id $(RUNID) @@ -48,34 +71,34 @@ cd simplerun ; $(MEGATEST) -server - -debug $(DEBUG) test1 : cleanprep test2 : fullprep - cd fullrun;$(MEGATEST) -preclean -runtests ez_pass,runfirst/a/% -reqtarg ubuntu/nfs/none :runname $(RUNNAME) -debug $(DEBUG) $(LOGGING) - cd fullrun;megatest -preclean -runtests % -target ubuntu/nfs/none :runname $(RUNNAME)_01 -testpatt %/,%/ai -debug $(DEBUG) - cd fullrun;megatest -preclean -runtests %/,%/ai -target ubuntu/nfs/none :runname $(RUNAME)_02 -debug $(DEBUG) - cd fullrun;megatest -preclean -runtests runfirst/%,%/ai -target ubuntu/nfs/none :runname $(RUNNAME)_02 -debug $(DEBUG) - cd fullrun;megatest -runtests %/,%/winter -target ubuntu/nfs/none :runname $(RUNNAME)_03 -debug $(DEBUG) - sleep 40;cd fullrun;megatest -target ubuntu/nfs/none :runname $(RUNNAME) -set-state-status COMPLETED,FORCED :state COMPLETED :status PASS -testpatt ez_p%s,runfirst/ -debug $(DEBUG) $(LOGGING) + cd fullrun;$(MEGATEST) -preclean -runtests ez_pass,runfirst/a/% -reqtarg ubuntu/nfs/none -runname $(RUNNAME) -debug $(DEBUG) $(LOGGING) + cd fullrun;megatest -preclean -runtests % -target ubuntu/nfs/none -runname $(RUNNAME)_01 -testpatt %/,%/ai -debug $(DEBUG) + cd fullrun;megatest -preclean -runtests %/,%/ai -target ubuntu/nfs/none -runname $(RUNAME)_02 -debug $(DEBUG) + cd fullrun;megatest -preclean -runtests runfirst/%,%/ai -target ubuntu/nfs/none -runname $(RUNNAME)_02 -debug $(DEBUG) + cd fullrun;megatest -runtests %/,%/winter -target ubuntu/nfs/none -runname $(RUNNAME)_03 -debug $(DEBUG) + sleep 40;cd fullrun;megatest -target ubuntu/nfs/none -runname $(RUNNAME) -set-state-status COMPLETED,FORCED :state COMPLETED :status PASS -testpatt ez_p%s,runfirst/ -debug $(DEBUG) $(LOGGING) test3 : fullprep test3a test3b test3a : @echo Run runfirst and any waitons. - cd fullrun;$(MEGATEST) -preclean -runtests runfirst -reqtarg ubuntu/nfs/none :runname $(RUNNAME)_b + cd fullrun;$(MEGATEST) -preclean -runtests runfirst -reqtarg ubuntu/nfs/none -runname $(RUNNAME)_b test3b : @echo Run all_toplevel and all waitons - cd fullrun;$(MEGATEST) -preclean -runtests all_toplevel -reqtarg ubuntu/nfs/none :runname $(RUNNAME)_c + cd fullrun;$(MEGATEST) -preclean -runtests all_toplevel -reqtarg ubuntu/nfs/none -runname $(RUNNAME)_c test4 : cleanprep @echo "WARNING: No longer running fullprep, test converage may be lessened" - cd fullrun;time $(MEGATEST) -debug $(DEBUG) -run-wait -runtests % -reqtarg ubuntu/nfs/none :runname $(RUNNAME)_b -m "This is a comment specific to a run" -v $(LOGGING) + cd fullrun;time $(MEGATEST) -debug $(DEBUG) -run-wait -run -testpatt % -reqtarg ubuntu/nfs/none -runname $(RUNNAME)_b -m "This is a comment specific to a run" -v $(LOGGING) test4a : cleanprep - cd fullrun;time $(MEGATEST) -debug $(DEBUG) -preclean -runtests all_toplevel -reqtarg ubuntu/nfs/none :runname $(RUNNAME)_b -m "This is a comment specific to a run" -v $(LOGGING) + cd fullrun;time $(MEGATEST) -debug $(DEBUG) -preclean -run -testpatt all_toplevel -reqtarg ubuntu/nfs/none -runname $(RUNNAME)_b -m "This is a comment specific to a run" -v $(LOGGING) # NOTE: Only one instance can be a server test5 : cleanprep rm -f fullrun/a*.log fullrun/logs/* @echo "WARNING: No longer running fullprep, test converage may be lessened" @@ -85,11 +108,11 @@ cd fullrun;sleep 5;$(MEGATEST) -preclean -runtests % -target ubuntu/nfs/sleep60 :runname $(RUNNAME)_ac -debug $(DEBUG) $(LOGGING) > ac.log 2> ac.log & cd fullrun;sleep 8;$(MEGATEST) -preclean -runtests % -target ubuntu/nfs/sleep240 :runname $(RUNNAME)_ad -debug $(DEBUG) $(LOGGING) > ad.log 2> ad.log & # cd fullrun;sleep 0;$(MEGATEST) -preclean -runtests % -target $(TARGET) :runname $(RUNNAME)_af -debug $(DEBUG) $(LOGGING) > af.log 2> af.log & # MUST ADD THIS BACK IN ASAP!!!! - # cd fullrun;sleep 10;$(MEGATEST) -run-wait -target $(TARGET) :runname % -testpatt % :state RUNNING,LAUNCHED,NOT_STARTED,REMOTEHOSTSTART;echo ALL DONE +# cd fullrun;sleep 10;$(MEGATEST) -run-wait -target $(TARGET) :runname % -testpatt % :state RUNNING,LAUNCHED,NOT_STARTED,REMOTEHOSTSTART;echo ALL DONE test6: fullprep cd fullrun;$(MEGATEST) -preclean -runtests runfirst -testpatt %/1 -reqtarg ubuntu/nfs/none :runname $(RUNNAME)_itempatt -v cd fullrun;$(MEGATEST) -preclean -runtests runfirst -testpatt %blahha% -reqtarg ubuntu/nfs/none :runname $(RUNNAME)_itempatt -debug 10 cd fullrun;$(MEGATEST) -rollup :runname newrun -target ubuntu/nfs/none -debug 10 @@ -171,11 +194,11 @@ cd mintest;$(MEGATEST) -server - -debug $(DEBUG) > server.log 2> server.log & sleep 3 cd mintest;$(DASHBOARD) -rows 18 & cleanprep : ../*.scm Makefile */*.config build - mkdir -p fullrun/tmp/mt_runs fullrun/tmp/mt_links /tmp/$(USER)/adisk1 + mkdir -p fullrun/tmp/mt_runs fullrun/tmp/mt_links /tmp/$(USER)/adisk1 fullrun/logs rm -f */logging.db touch cleanprep fullprep : cleanprep cd fullrun;$(MEGATEST) -remove-runs :runname $(RUNNAME)% -target %/%/% -testpatt %/% Index: tests/dep-tests/common.testconfig ================================================================== --- tests/dep-tests/common.testconfig +++ tests/dep-tests/common.testconfig @@ -1,5 +1,21 @@ +# Copyright 2006-2017, Matthew Welland. +# +# This file is part of Megatest. +# +# Megatest is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# Megatest is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with Megatest. If not, see . [ezsteps] delay sleep $SPEED;echo "Delayed $SPEED seconds" # lookup table for waitons # Index: tests/dep-tests/common_itemstable.testconfig ================================================================== --- tests/dep-tests/common_itemstable.testconfig +++ tests/dep-tests/common_itemstable.testconfig @@ -1,4 +1,20 @@ +# Copyright 2006-2017, Matthew Welland. +# +# This file is part of Megatest. +# +# Megatest is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# Megatest is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with Megatest. If not, see . [itemstable] VIEW layout layout layout schematic schematic schematic CELL ntran ptran diode ntran ptran diode Index: tests/dep-tests/megatest.config ================================================================== --- tests/dep-tests/megatest.config +++ tests/dep-tests/megatest.config @@ -1,5 +1,21 @@ +# Copyright 2006-2017, Matthew Welland. +# +# This file is part of Megatest. +# +# Megatest is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# Megatest is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with Megatest. If not, see . [fields] # this field changes the dep tree DEPS TEXT # this field changes the test run time; 0 .. N or random Index: tests/dep-tests/runconfigs.config ================================================================== --- tests/dep-tests/runconfigs.config +++ tests/dep-tests/runconfigs.config @@ -1,5 +1,21 @@ +# Copyright 2006-2017, Matthew Welland. +# +# This file is part of Megatest. +# +# Megatest is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# Megatest is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with Megatest. If not, see . [default] # [DEPS/SPEED] [simple/0] Index: tests/dep-tests/tests/aggregate/testconfig ================================================================== --- tests/dep-tests/tests/aggregate/testconfig +++ tests/dep-tests/tests/aggregate/testconfig @@ -1,4 +1,21 @@ +# Copyright 2006-2017, Matthew Welland. +# +# This file is part of Megatest. +# +# Megatest is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# Megatest is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with Megatest. If not, see . + [include #{getenv MT_RUN_AREA_HOME}/common.testconfig] [requirements] waiton #{get #{getenv DEPS} aggregate} Index: tests/dep-tests/tests/genlib/testconfig ================================================================== --- tests/dep-tests/tests/genlib/testconfig +++ tests/dep-tests/tests/genlib/testconfig @@ -1,5 +1,22 @@ +# Copyright 2006-2017, Matthew Welland. +# +# This file is part of Megatest. +# +# Megatest is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# Megatest is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with Megatest. If not, see . + [include #{getenv MT_RUN_AREA_HOME}/common.testconfig] [itemstable] VIEWTYPE layout schematic Index: tests/dep-tests/tests/results/testconfig ================================================================== --- tests/dep-tests/tests/results/testconfig +++ tests/dep-tests/tests/results/testconfig @@ -1,5 +1,22 @@ +# Copyright 2006-2017, Matthew Welland. +# +# This file is part of Megatest. +# +# Megatest is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# Megatest is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with Megatest. If not, see . + [include #{getenv MT_RUN_AREA_HOME}/common.testconfig] [requirements] waiton #{get #{getenv DEPS} results} Index: tests/dep-tests/tests/setup/testconfig ================================================================== --- tests/dep-tests/tests/setup/testconfig +++ tests/dep-tests/tests/setup/testconfig @@ -1,2 +1,19 @@ +# Copyright 2006-2017, Matthew Welland. +# +# This file is part of Megatest. +# +# Megatest is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# Megatest is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with Megatest. If not, see . + [include #{getenv MT_RUN_AREA_HOME}/common.testconfig] Index: tests/dep-tests/tests/test1/testconfig ================================================================== --- tests/dep-tests/tests/test1/testconfig +++ tests/dep-tests/tests/test1/testconfig @@ -1,5 +1,22 @@ +# Copyright 2006-2017, Matthew Welland. +# +# This file is part of Megatest. +# +# Megatest is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# Megatest is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with Megatest. If not, see . + [include #{getenv MT_RUN_AREA_HOME}/common.testconfig] [include #{getenv MT_RUN_AREA_HOME}/common_itemstable.testconfig] [requirements] Index: tests/dep-tests/tests/test2/testconfig ================================================================== --- tests/dep-tests/tests/test2/testconfig +++ tests/dep-tests/tests/test2/testconfig @@ -1,5 +1,22 @@ +# Copyright 2006-2017, Matthew Welland. +# +# This file is part of Megatest. +# +# Megatest is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# Megatest is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with Megatest. If not, see . + [include #{getenv MT_RUN_AREA_HOME}/common.testconfig] [include #{getenv MT_RUN_AREA_HOME}/common_itemstable.testconfig] [requirements] Index: tests/dynamic-waiton-example/common.testconfig ================================================================== --- tests/dynamic-waiton-example/common.testconfig +++ tests/dynamic-waiton-example/common.testconfig @@ -1,5 +1,22 @@ +# Copyright 2006-2017, Matthew Welland. +# +# This file is part of Megatest. +# +# Megatest is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# Megatest is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with Megatest. If not, see . + [ezsteps] delay sleep $SPEED;echo "Delayed $SPEED seconds" [requirements] #{getenv WAITON_#{getenv MT_TEST_NAME}} Index: tests/dynamic-waiton-example/common_itemstable.testconfig ================================================================== --- tests/dynamic-waiton-example/common_itemstable.testconfig +++ tests/dynamic-waiton-example/common_itemstable.testconfig @@ -1,4 +1,21 @@ +# Copyright 2006-2017, Matthew Welland. +# +# This file is part of Megatest. +# +# Megatest is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# Megatest is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with Megatest. If not, see . + [itemstable] VIEW layout layout layout schematic schematic schematic CELL ntran ptran diode ntran ptran diode Index: tests/dynamic-waiton-example/megatest.config ================================================================== --- tests/dynamic-waiton-example/megatest.config +++ tests/dynamic-waiton-example/megatest.config @@ -1,5 +1,22 @@ +# Copyright 2006-2017, Matthew Welland. +# +# This file is part of Megatest. +# +# Megatest is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# Megatest is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with Megatest. If not, see . + [fields] # this field changes the dep tree DEPS TEXT # this field changes the test run time; 0 .. N or random Index: tests/dynamic-waiton-example/runconfigs.config ================================================================== --- tests/dynamic-waiton-example/runconfigs.config +++ tests/dynamic-waiton-example/runconfigs.config @@ -1,5 +1,22 @@ +# Copyright 2006-2017, Matthew Welland. +# +# This file is part of Megatest. +# +# Megatest is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# Megatest is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with Megatest. If not, see . + [default] WAITON_setup WAITON_genlib waiton setup WAITON_test1 waiton genlib WAITON_aggregate waiton test1 Index: tests/dynamic-waiton-example/tests/aggregate/testconfig ================================================================== --- tests/dynamic-waiton-example/tests/aggregate/testconfig +++ tests/dynamic-waiton-example/tests/aggregate/testconfig @@ -1,2 +1,19 @@ +# Copyright 2006-2017, Matthew Welland. +# +# This file is part of Megatest. +# +# Megatest is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# Megatest is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with Megatest. If not, see . + [include #{getenv MT_RUN_AREA_HOME}/common.testconfig] Index: tests/dynamic-waiton-example/tests/genlib/testconfig ================================================================== --- tests/dynamic-waiton-example/tests/genlib/testconfig +++ tests/dynamic-waiton-example/tests/genlib/testconfig @@ -1,5 +1,22 @@ +# Copyright 2006-2017, Matthew Welland. +# +# This file is part of Megatest. +# +# Megatest is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# Megatest is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with Megatest. If not, see . + [include #{getenv MT_RUN_AREA_HOME}/common.testconfig] [itemstable] VIEWTYPE layout schematic Index: tests/dynamic-waiton-example/tests/results/testconfig ================================================================== --- tests/dynamic-waiton-example/tests/results/testconfig +++ tests/dynamic-waiton-example/tests/results/testconfig @@ -1,2 +1,19 @@ +# Copyright 2006-2017, Matthew Welland. +# +# This file is part of Megatest. +# +# Megatest is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# Megatest is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with Megatest. If not, see . + [include #{getenv MT_RUN_AREA_HOME}/common.testconfig] Index: tests/dynamic-waiton-example/tests/setup/testconfig ================================================================== --- tests/dynamic-waiton-example/tests/setup/testconfig +++ tests/dynamic-waiton-example/tests/setup/testconfig @@ -1,2 +1,19 @@ +# Copyright 2006-2017, Matthew Welland. +# +# This file is part of Megatest. +# +# Megatest is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# Megatest is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with Megatest. If not, see . + [include #{getenv MT_RUN_AREA_HOME}/common.testconfig] Index: tests/dynamic-waiton-example/tests/test1/testconfig ================================================================== --- tests/dynamic-waiton-example/tests/test1/testconfig +++ tests/dynamic-waiton-example/tests/test1/testconfig @@ -1,3 +1,20 @@ +# Copyright 2006-2017, Matthew Welland. +# +# This file is part of Megatest. +# +# Megatest is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# Megatest is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with Megatest. If not, see . + [include #{getenv MT_RUN_AREA_HOME}/common.testconfig] [include #{getenv MT_RUN_AREA_HOME}/common_itemstable.testconfig] Index: tests/dynamic-waiton-example/tests/test2/testconfig ================================================================== --- tests/dynamic-waiton-example/tests/test2/testconfig +++ tests/dynamic-waiton-example/tests/test2/testconfig @@ -1,3 +1,20 @@ +# Copyright 2006-2017, Matthew Welland. +# +# This file is part of Megatest. +# +# Megatest is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# Megatest is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with Megatest. If not, see . + [include #{getenv MT_RUN_AREA_HOME}/common.testconfig] [include #{getenv MT_RUN_AREA_HOME}/common_itemstable.testconfig] Index: tests/fdktestqa/fdk.config ================================================================== --- tests/fdktestqa/fdk.config +++ tests/fdktestqa/fdk.config @@ -1,36 +1,45 @@ +# Copyright 2006-2017, Matthew Welland. +# +# This file is part of Megatest. +# +# Megatest is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# Megatest is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with Megatest. If not, see . + [fields] SYSTEM TEXT RELEASE TEXT [setup] # Adjust max_concurrent_jobs to limit how much you load your machines # max_concurrent_jobs 150 -max_concurrent_jobs 1000 +max_concurrent_jobs 3000 # This is your link path, you can move it but it is generally better to keep it stable linktree #{shell readlink -f #{getenv MT_RUN_AREA_HOME}/../simplelinks} [include testqa/configs/megatest.abc.config] -# timeout 0.025 - [jobtools] maxload 4 -launcher nbfake +# launcher smartlauncher --cores 1 --memory 1 +launcher nbjob run --target pdx_soft --class 'SLES11&&1C&&1G' --qslot /icf/fdk/soft +# launcher bsub -q priority -o $MT_TEST_RUN_DIR/openlava.log [server] # timeout 0.01 # homehost xena # homehost 143.182.225.38 - # force server -server-query-threshold 0 - - -[jobtools] -# launcher nbq -P ch_vp -C SLES11_EM64T_4G -Q /ciaf/fdk -launcher nbfake -maxload 4 - -# launcher bsub -q priority -o $MT_TEST_RUN_DIR/openlava.log +# server-query-threshold 0 + Index: tests/fdktestqa/testqa/Makefile ================================================================== --- tests/fdktestqa/testqa/Makefile +++ tests/fdktestqa/testqa/Makefile @@ -1,38 +1,56 @@ +# Copyright 2006-2017, Matthew Welland. +# +# This file is part of Megatest. +# +# Megatest is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# Megatest is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with Megatest. If not, see . + BINDIR = $(PWD)/../../../bin PATH := $(BINDIR):$(PATH) MEGATEST = $(BINDIR)/megatest DASHBOARD = $(BINDIR)/dashboard NEWDASHBOARD = $(BINDIR)/newdashboard RUNNAME = a NUMTESTS = 20 +SUBTARG = b all : - $(MEGATEST) -remove-runs -target a/b :runname c -testpatt %/% - $(MEGATEST) -runtests % -target a/b :runname c + $(MEGATEST) -remove-runs -target a/b -runname c -testpatt %/% + $(MEGATEST) -run -testpatt % -target a/b -runname c bigbig : for tn in a b c d;do \ - ($(MEGATEST) -runtests % -target a/b :runname $tn & ) ; \ + (NUMTESTS=1000 $(MEGATEST) -run -testpatt % -target a/$(SUBTARG) -runname $$tn & ) ; \ done waitonpatt : - megatest -remove-runs -runname waitonpatt -target a/b -testpatt % + megatest -remove-runs -runname waitonpatt -target a/$(SUBTARG) -testpatt % NUMTESTS=15 megatest -run -target a/b -runname waitonpatt -testpatt bigrun3/%8 waitonall : megatest -remove-runs -runname waitonall -target a/b -testpatt % NUMTESTS=20 megatest -run -target a/b -runname waitonall -testpatt alltop bigrun : - NUMTESTS=$(NUMTESTS) $(MEGATEST) -runtests bigrun -target a/bigrun :runname a$(shell date +%V) + NUMTESTS=$(NUMTESTS) $(MEGATEST) -run -testpatt bigrun -target a/bigrun -runname a$(shell date +%V) bigrun2 : - NUMTESTS=$(NUMTESTS) $(MEGATEST) -runtests bigrun2 -target a/bigrun2 :runname a$(shell date +%V) + NUMTESTS=$(NUMTESTS) $(MEGATEST) -run -testpatt bigrun2 -target a/bigrun2 -runname a$(shell date +%V) bigrun3 : - NUMTESTS=$(NUMTESTS) $(MEGATEST) -runtests bigrun3 -target a/bigrun3 :runname $(RUNNAME) + NUMTESTS=$(NUMTESTS) $(MEGATEST) -run -testpatt bigrun3 -target a/bigrun3 -runname $(RUNNAME) dashboard : mkdir -p ../simpleruns $(DASHBOARD) -rows 20 & @@ -41,6 +59,6 @@ compile : (cd ../../..;make -j && make install) clean : - rm -rf ../simple*/*/* megatest.db db/* ../simple*/.db/* logs/* monitor.db + rm -rf ../simple*/*/* megatest.db db/* ../simple*/.db/* logs/* monitor.db /tmp/$(USER)/megatest_localdb/testqa .server Index: tests/fdktestqa/testqa/README ================================================================== --- tests/fdktestqa/testqa/README +++ tests/fdktestqa/testqa/README @@ -1,1 +1,18 @@ +# Copyright 2006-2017, Matthew Welland. +# +# This file is part of Megatest. +# +# Megatest is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# Megatest is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with Megatest. If not, see . + set NUMTESTS to set the number of tests that will be run. A small number (say 20) illustrates itemwait well. Index: tests/fdktestqa/testqa/configs/megatest.abc.config ================================================================== --- tests/fdktestqa/testqa/configs/megatest.abc.config +++ tests/fdktestqa/testqa/configs/megatest.abc.config @@ -1,5 +1,22 @@ +# Copyright 2006-2017, Matthew Welland. +# +# This file is part of Megatest. +# +# Megatest is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# Megatest is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with Megatest. If not, see . + # Valid values for state and status for steps, NB// It is not recommended you use this [validvalues] state start end completed # Job tools are more advanced ways to control how your jobs are launched Index: tests/fdktestqa/testqa/configs/megatest.def.config ================================================================== --- tests/fdktestqa/testqa/configs/megatest.def.config +++ tests/fdktestqa/testqa/configs/megatest.def.config @@ -1,5 +1,22 @@ +# Copyright 2006-2017, Matthew Welland. +# +# This file is part of Megatest. +# +# Megatest is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# Megatest is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with Megatest. If not, see . + # You can override environment variables for all your tests here [env-override] EXAMPLE_VAR example value # As you run more tests you may need to add additional disks, the names are arbitrary but must be unique ADDED tests/fdktestqa/testqa/local.config.example Index: tests/fdktestqa/testqa/local.config.example ================================================================== --- /dev/null +++ tests/fdktestqa/testqa/local.config.example @@ -0,0 +1,32 @@ +# Copyright 2006-2017, Matthew Welland. +# +# This file is part of Megatest. +# +# Megatest is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# Megatest is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with Megatest. If not, see . + +[host-types] +general #MTLOWESTLOAD xena zeus + +[jobtools] +launcher nbfake +maxload 1.5 +flexi-launcher yes +# useshell no + +[setup] +launch-delay 1 +launchwait no + +[launchers] +% general Index: tests/fdktestqa/testqa/megatest.config ================================================================== --- tests/fdktestqa/testqa/megatest.config +++ tests/fdktestqa/testqa/megatest.config @@ -1,11 +1,39 @@ +# Copyright 2006-2017, Matthew Welland. +# +# This file is part of Megatest. +# +# Megatest is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# Megatest is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with Megatest. If not, see . + [setup] testcopycmd cp --remove-destination -rlv TEST_SRC_PATH/. TEST_TARG_PATH/. >> TEST_TARG_PATH/mt_launch.log 2>> TEST_TARG_PATH/mt_launch.log # launchwait no +# launch-delay 0.1 +launch-delay 0 + +[jobtools] +maxhomehostload 4 + +[server] +# runtime 180 +# timeout is in hours, this is how long the server will stay alive when not being used. +# timeout 0.1 # All these are overridden in ../fdk.config # [jobtools] # launcher nbfake # launcher bsub -q priority -o $MT_TEST_RUN_DIR/openlava.log [include ../fdk.config] +[include local.config] Index: tests/fdktestqa/testqa/runconfigs.config ================================================================== --- tests/fdktestqa/testqa/runconfigs.config +++ tests/fdktestqa/testqa/runconfigs.config @@ -1,5 +1,24 @@ +# Copyright 2006-2017, Matthew Welland. +# +# This file is part of Megatest. +# +# Megatest is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# Megatest is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with Megatest. If not, see . + +[include local.runconfigs] + [default] ALLTESTS see this variable # Your variables here are grouped by targets [SYSTEM/RELEASE] [SYSTEM_val/RELEASE_val] Index: tests/fdktestqa/testqa/runsuite.sh ================================================================== --- tests/fdktestqa/testqa/runsuite.sh +++ tests/fdktestqa/testqa/runsuite.sh @@ -1,18 +1,34 @@ #!/bin/bash -(cd ../../..;make && make install) || exit 1 -export PATH=$PWD/../../../bin:$PATH +# Copyright 2006-2017, Matthew Welland. +# +# This file is part of Megatest. +# +# Megatest is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# Megatest is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with Megatest. If not, see . + +# (cd ../../..;make && make install) || exit 1 +# export PATH=$PWD/../../../bin:$PATH for i in a b c d e f;do # g h i j k l m n o p q r s t u v w x y z;do - megatest -runtests % -target a/b :runname $i & + viewscreen megatest -run -testpatt % -target a/b -runname w$(date +%U.%u.%H)$i done echo "" > num-running.log while true; do - foo=`megatest -list-runs % | grep RUNNING | wc -l` + foo=$(megatest -list-runs % | grep RUNNING | wc -l) echo "Num running at `date` $foo" echo "$foo at `date`" >> num-running.log - # to make the test go at a reasonable clip only gather this info ever minute - sleep 1m + sleep 10 done Index: tests/fdktestqa/testqa/tests/alltop/testconfig ================================================================== --- tests/fdktestqa/testqa/tests/alltop/testconfig +++ tests/fdktestqa/testqa/tests/alltop/testconfig @@ -1,5 +1,22 @@ +# Copyright 2006-2017, Matthew Welland. +# +# This file is part of Megatest. +# +# Megatest is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# Megatest is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with Megatest. If not, see . + # Add additional steps here. Format is "stepname script" [vars] step1var step1.sh [ezsteps] Index: tests/fdktestqa/testqa/tests/bigrun/step1.sh ================================================================== --- tests/fdktestqa/testqa/tests/bigrun/step1.sh +++ tests/fdktestqa/testqa/tests/bigrun/step1.sh @@ -1,9 +1,26 @@ #!/bin/bash +# Copyright 2006-2017, Matthew Welland. +# +# This file is part of Megatest. +# +# Megatest is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# Megatest is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with Megatest. If not, see . + if [ $NUMBER -lt 10 ];then sleep 20 - sleep `echo 4 * $NUMBER | bc` + sleep `echo 4 \* $NUMBER | bc` else sleep 130 fi if [[ $RANDOM -lt 10000 ]];then Index: tests/fdktestqa/testqa/tests/bigrun/testconfig ================================================================== --- tests/fdktestqa/testqa/tests/bigrun/testconfig +++ tests/fdktestqa/testqa/tests/bigrun/testconfig @@ -1,5 +1,22 @@ +# Copyright 2006-2017, Matthew Welland. +# +# This file is part of Megatest. +# +# Megatest is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# Megatest is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with Megatest. If not, see . + # Add additional steps here. Format is "stepname script" [vars] step1var step1.sh [ezsteps] Index: tests/fdktestqa/testqa/tests/bigrun2/step1.sh ================================================================== --- tests/fdktestqa/testqa/tests/bigrun2/step1.sh +++ tests/fdktestqa/testqa/tests/bigrun2/step1.sh @@ -3,7 +3,24 @@ # if [ -e $prev_test/testconfig ]; then # exit 0 # else # exit 1 # fi +# Copyright 2006-2017, Matthew Welland. +# +# This file is part of Megatest. +# +# Megatest is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# Megatest is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with Megatest. If not, see . + exit 0 Index: tests/fdktestqa/testqa/tests/bigrun2/testconfig ================================================================== --- tests/fdktestqa/testqa/tests/bigrun2/testconfig +++ tests/fdktestqa/testqa/tests/bigrun2/testconfig @@ -1,5 +1,22 @@ +# Copyright 2006-2017, Matthew Welland. +# +# This file is part of Megatest. +# +# Megatest is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# Megatest is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with Megatest. If not, see . + # Add additional steps here. Format is "stepname script" [ezsteps] step1 step1.sh # Test requirements are specified here @@ -9,11 +26,11 @@ mode itemwait itemmap .*/ # Iteration for your tests are controlled by the items section [items] -NUMBER #{scheme (string-intersperse (map (lambda (x)(conc "blah/" x)) \ +NUMBER #{scheme (string-intersperse (map (lambda (x)(conc (if (getenv "USEBLAH") "blah/" "") x)) \ (map number->string (sort (let loop ((a 0)(res '())) \ (if (<= a (or (any->number (get-environment-variable "NUMTESTS")) 2500)) \ (loop (+ a 1)(cons a res)) res)) <))) " ")} Index: tests/fdktestqa/testqa/tests/bigrun3/step1.sh ================================================================== --- tests/fdktestqa/testqa/tests/bigrun3/step1.sh +++ tests/fdktestqa/testqa/tests/bigrun3/step1.sh @@ -3,7 +3,24 @@ # if [ -e $prev_test/testconfig ]; then # exit 0 # else # exit 1 # fi +# Copyright 2006-2017, Matthew Welland. +# +# This file is part of Megatest. +# +# Megatest is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# Megatest is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with Megatest. If not, see . + exit 0 Index: tests/fdktestqa/testqa/tests/bigrun3/testconfig ================================================================== --- tests/fdktestqa/testqa/tests/bigrun3/testconfig +++ tests/fdktestqa/testqa/tests/bigrun3/testconfig @@ -1,5 +1,22 @@ +# Copyright 2006-2017, Matthew Welland. +# +# This file is part of Megatest. +# +# Megatest is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# Megatest is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with Megatest. If not, see . + # Add additional steps here. Format is "stepname script" [ezsteps] step1 step1.sh # Test requirements are specified here Index: tests/fixpath.csh ================================================================== --- tests/fixpath.csh +++ tests/fixpath.csh @@ -1,1 +1,17 @@ +# Copyright 2006-2017, Matthew Welland. +# +# This file is part of Megatest. +# +# Megatest is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# Megatest is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with Megatest. If not, see . setenv PATH `readlink -f ../bin`:$PATH Index: tests/fixpath.sh ================================================================== --- tests/fixpath.sh +++ tests/fixpath.sh @@ -1,1 +1,18 @@ +# Copyright 2006-2017, Matthew Welland. +# +# This file is part of Megatest. +# +# Megatest is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# Megatest is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with Megatest. If not, see . + export PATH=$(readlink -f ../bin):$PATH DELETED tests/fslsync/megatest.config Index: tests/fslsync/megatest.config ================================================================== --- tests/fslsync/megatest.config +++ /dev/null @@ -1,20 +0,0 @@ -[fields] -YEAR TEXT -WEEKNUM TEXT -DAY TEXT - -[setup] -# Adjust max_concurrent_jobs to limit how much you load your machines -max_concurrent_jobs 50 - -# This is your link path, you can move it but it is generally better to keep it stable -linktree #{shell readlink -f #{getenv MT_RUN_AREA_HOME}/fslsynclinks} - -# Job tools are more advanced ways to control how your jobs are launched -[jobtools] -useshell yes -launcher nbfind - -# As you run more tests you may need to add additional disks, the names are arbitrary but must be unique -[disks] -disk0 #{shell readlink -f #{getenv MT_RUN_AREA_HOME}/fslsyncruns} DELETED tests/fslsync/runconfigs.config Index: tests/fslsync/runconfigs.config ================================================================== --- tests/fslsync/runconfigs.config +++ /dev/null @@ -1,5 +0,0 @@ -[default] -WORKAREA /tmp/#{getenv USER}/fslsync -FSLSAREA /tmp/#{getenv USER}/fsls -AREANAMES code data -SITENAMES #{shell cat $MT_RUN_AREA_HOME/sites.dat} DELETED tests/fslsync/sites.dat.template Index: tests/fslsync/sites.dat.template ================================================================== --- tests/fslsync/sites.dat.template +++ /dev/null @@ -1,1 +0,0 @@ -site1 DELETED tests/fslsync/tests/setup/mkdirs.logpro Index: tests/fslsync/tests/setup/mkdirs.logpro ================================================================== --- tests/fslsync/tests/setup/mkdirs.logpro +++ /dev/null @@ -1,8 +0,0 @@ -;; You should have at least one expect:required. This ensures that your process ran -(expect:required in "LogFileBody" > 0 "done" #/done/) - -;; You may need ignores to suppress false error or warning hits from the later expects -;; NOTE: Order is important here! -(expect:ignore in "LogFileBody" < 99 "Ignore the word error in comments" #/^\/\/.*error/) -(expect:warning in "LogFileBody" = 0 "Any warning" #/warn/) -(expect:error in "LogFileBody" = 0 "Any error" (list #/ERROR/ #/error/)) ;; but disallow any other errors DELETED tests/fslsync/tests/setup/mkdirs.sh Index: tests/fslsync/tests/setup/mkdirs.sh ================================================================== --- tests/fslsync/tests/setup/mkdirs.sh +++ /dev/null @@ -1,11 +0,0 @@ -#!/usr/bin/env bash - -# Create needed directories both local and remote - -# Remote -ssh $SITENAME mkdir -vp $WORKAREA/$SITENAME/$AREANAME - -# Local -mkdir -vp $WORKAREA/$SITENAME/$AREANAME - -echo done DELETED tests/fslsync/tests/setup/seedcache.logpro Index: tests/fslsync/tests/setup/seedcache.logpro ================================================================== --- tests/fslsync/tests/setup/seedcache.logpro +++ /dev/null @@ -1,8 +0,0 @@ -;; You should have at least one expect:required. This ensures that your process ran -(expect:required in "LogFileBody" > 0 "done" #/done/) - -;; You may need ignores to suppress false error or warning hits from the later expects -;; NOTE: Order is important here! -(expect:ignore in "LogFileBody" < 99 "Ignore the word error in comments" #/^\/\/.*error/) -(expect:warning in "LogFileBody" = 0 "Any warning" #/warn/) -(expect:error in "LogFileBody" = 0 "Any error" (list #/ERROR/ #/error/)) ;; but disallow any other errors DELETED tests/fslsync/tests/setup/seedcache.sh Index: tests/fslsync/tests/setup/seedcache.sh ================================================================== --- tests/fslsync/tests/setup/seedcache.sh +++ /dev/null @@ -1,6 +0,0 @@ -#!/usr/bin/env bash - -# Copy any non-existant files to the cache before doing the rsync -# in the hopes of saving some time. - -echo done DELETED tests/fslsync/tests/setup/testconfig Index: tests/fslsync/tests/setup/testconfig ================================================================== --- tests/fslsync/tests/setup/testconfig +++ /dev/null @@ -1,21 +0,0 @@ -# Add additional steps here. Format is "stepname script" -[ezsteps] -mkdirs mkdirs.sh -seedcache seedcache.sh - -# Test requirements are specified here -[requirements] -priority 0 - -# Iteration for your tests are controlled by the items section -[items] -AREANAME #{getenv AREANAMES} -SITENAME #{getenv SITENAMES} - -# test_meta is a section for storing additional data on your test -[test_meta] -author matt -owner matt -description Setup needed directories and seed the caches -tags tagone,tagtwo -reviewed never DELETED tests/fslsync/tests/sync/fsync.logpro Index: tests/fslsync/tests/sync/fsync.logpro ================================================================== --- tests/fslsync/tests/sync/fsync.logpro +++ /dev/null @@ -1,8 +0,0 @@ -;; You should have at least one expect:required. This ensures that your process ran -(expect:required in "LogFileBody" > 0 "done" #/done/) - -;; You may need ignores to suppress false error or warning hits from the later expects -;; NOTE: Order is important here! -(expect:ignore in "LogFileBody" < 99 "Ignore the word error in comments" #/^\/\/.*error/) -(expect:warning in "LogFileBody" = 0 "Any warning" #/warn/) -(expect:error in "LogFileBody" = 0 "Any error" (list #/ERROR/ #/error/)) ;; but disallow any other errors DELETED tests/fslsync/tests/sync/fsync.sh Index: tests/fslsync/tests/sync/fsync.sh ================================================================== --- tests/fslsync/tests/sync/fsync.sh +++ /dev/null @@ -1,33 +0,0 @@ -#!/usr/bin/env bash - -# Get the list of fossils from the cache - -FILES=$(ls $FSLSAREA/$AREANAME|grep fossil) - -# Do the remote sync from CACHE to FOSSILS -ssh $SITENAME /bin/bash < 0 "done" #/done/) - -;; You may need ignores to suppress false error or warning hits from the later expects -;; NOTE: Order is important here! -(expect:ignore in "LogFileBody" < 99 "Ignore the word error in comments" #/^\/\/.*error/) -(expect:warning in "LogFileBody" = 0 "Any warning" #/warn/) -(expect:error in "LogFileBody" = 0 "Any error" (list #/ERROR/ #/error/)) ;; but disallow any other errors DELETED tests/fslsync/tests/sync/rsync.sh Index: tests/fslsync/tests/sync/rsync.sh ================================================================== --- tests/fslsync/tests/sync/rsync.sh +++ /dev/null @@ -1,11 +0,0 @@ -#!/usr/bin/env bash - -# Sync to remote cache -rsync -avz $FSLSAREA/$AREANAME/ $SITENAME:$WORKAREA/$SITENAME/$AREANAME/ & -# Sync to local cache -rsync -avz $SITENAME:$FSLSAREA/$AREANAME/ $WORKAREA/$SITENAME/$AREANAME/ & - -# Wait until rsyncs complete -wait - -echo done DELETED tests/fslsync/tests/sync/testconfig Index: tests/fslsync/tests/sync/testconfig ================================================================== --- tests/fslsync/tests/sync/testconfig +++ /dev/null @@ -1,22 +0,0 @@ -# Add additional steps here. Format is "stepname script" -[ezsteps] -rsync rsync.sh -fsync fsync.sh - -# Test requirements are specified here -[requirements] -waiton setup -priority 0 - -# Iteration for your tests are controlled by the items section -[items] -AREANAME #{getenv AREANAMES} -SITENAME #{getenv SITENAMES} - -# test_meta is a section for storing additional data on your test -[test_meta] -author matt -owner matt -description Sync fossils to remote -tags tagone,tagtwo -reviewed never DELETED tests/fullrun/afs.config Index: tests/fullrun/afs.config ================================================================== --- tests/fullrun/afs.config +++ /dev/null @@ -1,1 +0,0 @@ -TESTSTORUN priority_6 sqlitespeed/ag DELETED tests/fullrun/common_runconfigs.config Index: tests/fullrun/common_runconfigs.config ================================================================== --- tests/fullrun/common_runconfigs.config +++ /dev/null @@ -1,17 +0,0 @@ -[default] -FOOBARBAZZZZ not a useful value -BIGBOB $FOOBARBAZZZZ/bobby -FREDDY $sysname/$fsname -TOMMY [system pwd] - -[/tmp/mrwellan/env/ubuntu/afs] -BOGOUS Bob - -[default/ubuntu/nfs] -CURRENT /blah -ALT_VAR we should not see this one - -[ubuntu/nfs/none] -CURRENT /tmp/nada -UNIQUEVAR this one should be set - DELETED tests/fullrun/configs/mt_include_1.config Index: tests/fullrun/configs/mt_include_1.config ================================================================== --- tests/fullrun/configs/mt_include_1.config +++ /dev/null @@ -1,23 +0,0 @@ -[setup] -# exectutable /path/to/megatest -max_concurrent_jobs 250 - -linktree #{getenv MT_RUN_AREA_HOME}/tmp/mt_links - -[jobtools] -useshell yes -# ## launcher launches jobs, the job is managed on the target host -## by megatest, comment out launcher to run local -# workhosts localhost hermes -# launcher exec nbfake - -launcher nbfake -# launcher echo - -# launcher nbfind -# launcher nodanggood - -## use "xterm -e csi -- " as a launcher to examine the launch environment. -## exit with (exit) -## get a shell with (system "bash") -# launcher xterm -e csi -- DELETED tests/fullrun/configs/mt_include_2.config Index: tests/fullrun/configs/mt_include_2.config ================================================================== --- tests/fullrun/configs/mt_include_2.config +++ /dev/null @@ -1,2 +0,0 @@ -[disks] -disk0 #{scheme (create-directory "#{getenv MT_RUN_AREA_HOME}/tmp/mt_runs" #t)} DELETED tests/fullrun/ez_pass_linked/testconfig Index: tests/fullrun/ez_pass_linked/testconfig ================================================================== --- tests/fullrun/ez_pass_linked/testconfig +++ /dev/null @@ -1,13 +0,0 @@ -[setup] - -[ezsteps] -lookittmp ls /tmp -lookithome ls /home - -[test_meta] -author matt -owner bob -description This test runs a single ezstep which is expected to pass, no logpro file. - -tags first,single -reviewed 09/10/2011, by Matt DELETED tests/fullrun/megatest.config Index: tests/fullrun/megatest.config ================================================================== --- tests/fullrun/megatest.config +++ /dev/null @@ -1,300 +0,0 @@ -[fields] -sysname TEXT -fsname TEXT -datapath TEXT - -[graph] -g1 sqlite3:../../example.db alldat event_time var val stuff - -# refareas can be searched to find previous runs -# the path points to where megatest.db exists -[refareas] -area1 /tmp/oldarea/megatest - -[include ./configs/mt_include_1.config] - -[dashboard] -pre-command xterm -geometry 180x20 -e " -post-command |& tee results.log ;echo Press any key to continue;bash -c 'read -n 1 -s'" & -testsort -event_time - -[misc] -home #{shell readlink -f $MT_RUN_AREA_HOME} -parent #{shell readlink -f $MT_RUN_AREA_HOME/..} -testsuite #{shell basename $MT_RUN_AREA_HOME} - -[tests-paths] -1 #{get misc parent}/simplerun/tests - -[setup] - -# turn off faststart, put monitor.db in MT_RUN_AREA_HOME/db -# and set the dbdir to /var/tmp/$USER/mt_db to enable keeping -# the raw db in /var/tmp/$USER -# -faststart no -monitordir #{getenv MT_RUN_AREA_HOME}/db -dbdir #{getenv MT_RUN_AREA_HOME}/db - -# sync more aggressively to megatest-db -megatest-db yes - -# Set launchwait to no to use the more agressive code that does not wait for the launch to complete before proceeding -# this may save a few milliseconds on launching tests -# launchwait no -waivercommentpatt ^WW\d+ [a-z].* -incomplete-timeout 1 - -# wait for runs to completely complete. yes, anything else is no -run-wait yes - -# If set to "default" the old code is used. Otherwise defaults to 200 or uses -# numeric value given. -# -runqueue 20 - -# Default runtimelim 1d 1h 1m 10s -# -runtimelim 20m - -# Deadtime - when to consider tests dead (i.e. haven't heard from them in too long) -# Number in seconds, set to 20 seconds here to trigger a little trouble. Default is -# 1800 -# -deadtime 600 - -# It is possible (but not recommended) to override the rsync command used -# to populate the test directories. For test development the following -# example can be useful -# -testcopycmd cp --remove-destination -rsv TEST_SRC_PATH/. TEST_TARG_PATH/. >> TEST_TARG_PATH/mt_launch.log 2>> TEST_TARG_PATH/mt_launch.log - -# or for hard links - -# testcopycmd cp --remove-destination -rlv TEST_SRC_PATH/. TEST_TARG_PATH/. - -# FULL or 2, NORMAL or 1, OFF or 0 -synchronous 0 -# Throttle roughly scales the db access milliseconds to seconds delay -throttle 0.2 -# Max retries allows megatest to re-check that a tests status has changed -# as tests can have transient FAIL status occasionally -maxretries 20 - -# Setup continued. -[setup] - -# override the logview command -# -logviewer (%MTCMD%) 2> /dev/null > /dev/null - -# override the html viewer launch command -# -# htmlviewercmd firefox -new-window -htmlviewercmd arora - -# -runtests automatically deletes the records for tests with the listed states on starting up a run allowing them to re-run -# (nb// this is in addition to NOT_STARTED which is automatically re-run) -# -allow-auto-rerun INCOMPLETE ZERO_ITEMS -# could add: STUCK STUCK/DEAD UNKNOWN KILLED KILLREQ PREQ_DISCARD - -[validvalues] -state start end 0 1 - 2 -status pass fail n/a 0 1 running - 2 - -# These are set before all tests, override them -# in the testconfig [pre-launch-env-overrides] section -[env-override] - - -ALL_TOPLEVEL_TESTS exit_0 exit_1 ez_exit2_fail ez_fail ez_pass ezlog_fail \ - ezlog_fail_then_pass ezlog_pass ezlog_warn lineitem_fail lineitem_pass logpro_required_fail \ - manual_example neverrun priority_1 priority_10 priority_10_waiton_1 \ - priority_3 priority_4 priority_5 priority_6 priority_7 priority_8 \ - priority_9 runfirst singletest singletest2 sqlitespeed test_mt_vars \ - ez_fail_quick test1 test2 - -# This variable is honored by the loadrunner script. The value is in percent -MAX_ALLOWED_LOAD 200 - -# MT_XTERM_CMD overrides the terminal command -# MT_XTERM_CMD xterm -bg lightgreen -fg black - -SPECIAL_ENV_VARS overide them here - should be seen at launch and in the runs -TESTVAR [system readlink -f .] -DEADVAR [system ls] -VARWITHDOLLAR $HOME/.zshrc -WACKYVAR #{system ls > /dev/null} -WACKYVAR2 #{get validvalues state} -WACKYVAR3 #{getenv USER} -WACKYVAR4 #{scheme (+ 5 6 7)} -WACKYVAR5 #{getenv sysname}/#{getenv fsname}/#{getenv datapath} -WACKYVAR6 #{scheme (args:get-arg "-target")} -PREDICTABLE the_ans -MRAH MT_RUN_AREA_HOME=#{getenv MT_RUN_AREA_HOME} -# The empty var should have a definition with null string -EMPTY_VAR - -WRAPPEDVAR This var should have the work blah thrice: \ -blah \ -blah - -MYRUNNAME1 /this/is/#{getenv MT_RUNNAME}/my/runname -MYRUNNAME2 /this/is/[system echo $MT_RUNNAME]/my/runname - - -# XTERM [system xterm] -# RUNDEAD [system exit 56] - -[server] - -# force use of server always -# required yes - -# Use http instead of direct filesystem access -transport http -# transport fs -# transport nmsg - -synchronous 0 - -# If the server can't be started on this port it will try the next port until -# it succeeds -port 9080 - -# This server will keep running this number of hours after last access. -# Three minutes is 0.05 hours -# timeout 0.025 -timeout 0.01 - -# faststart; unless no, start server but proceed with writes until server started -# faststart no -faststart yes - -# Start server when average query takes longer than this -# server-query-threshold 55500 -server-query-threshold 1000 - -# daemonize yes -# hostname #{scheme (get-host-name)} - -## disks are: -## name host:/path/to/area -## -or- -## name /path/to/area -[disks] -disk0 /foobarbazz -disk1 not-a-disk - -[include ./configs/mt_include_2.config] - -[include #{getenv USER}_testing.config] - -[jobgroups] - -# NOTE: job groups will falsely count the toplevel test as a job. If possible add N -# to your jobgroups where N is the number of parallel runs you are likely to see -# -sqlite3 6 -blockz 10 -# to your jobgroups where N is the number of parallel runs you are likely to see -# - -#====================================================================== -# Machine flavors -# -# These specify lists of hosts or scripts to use or call for various -# flavors of task. -# -#====================================================================== - -[flavors] - -plain hosts: xena, phoebe -strong command: NBFAKE_HOST=zeus nbfake -arm hosts: cubian - -[archive] - -# where to get bup executable -# bup /path/to/bup - -# use machines of these flavor -useflavors plain -targsize 2G - -# minimum space required on an archive disk before allowing archiving to start (MB) -minspace 10 - -[archive-disks] - -# Archives will be organised under these paths like this: -# / -# Within the archive the data is structured like this: -# /// -disk0 /tmp/#{getenv USER}/adisk1 - -# Uncomment these to emulate a job queue with a long time (look in bin/sleeprunner for the time) -[jobtools] -launcher #{scheme (case (string->symbol (conc (getenv "datapath"))) \ - ((none) "nbfake") \ - ((openlava) "bsub -o $MT_LINKTREE/$MT_TARGET/$MT_RUNNAME.$MT_TESTNAME-$MT_ITEM_PATH.log") \ - ((sleeprunner) "sleeprunner") \ - (else "nbfake"))} - -# launcher bsub -q priority -o $MT_TEST_RUN_DIR/openlava.log - -# launcher #{shell if which bsub > /dev/null;then echo bsub -q priority -o openlava.log;else echo sleeprunner;fi} -# launcher nbfake - -[configf:settings trim-trailing-spaces yes] - -# Override the rollup for specific tests -[testrollup] -runfirst ls - -[test] -# VAL1 has trailing spaces -VAL1 Foo -VAL2 ==>#{get test VAL1}Bar<== no spaces between Foo and Bar to pass - -ltest #{scheme (case (string->symbol (conc (getenv "datapath"))) \ - ((none) "nbfake") \ - ((openlava) "bsub -o $MT_LINKTREE/$MT_TARGET/$MT_RUNNAME.$MT_TESTNAME-$MT_ITEM_PATH.log") \ - (else "sleeprunner"))} - -#================================================================ -# Flexi-launcher -#================================================================ -# -# [host-types] -# general ssh #{getbgesthost general} -# nbgeneral nbjob run JOBCOMMAND -log $MT_LINKTREE/$MT_TARGET/$MT_RUNNAME.$MT_TESTNAME-$MT_ITEM_PATH.lgo -# -# [hosts] -# general cubian xena -# -# [launchers] -# envsetup general -# xor/%/n 4C16G -# % nbgeneral -# -# [jobtools] -# launcher bsub -# # if defined and not "no" flexi-launcher will bypass launcher unless there is no -# # match. -# flexi-launcher yes - -[jobtools] -flexi-launcher yes - -[host-types] -general nbfake -alt #{get jobtools launcher} -local nbfake -remote #{get jobtools launcher} - -[launchers] -runfirst/sum% remote -% general DELETED tests/fullrun/multi-dboard-load-all.scm Index: tests/fullrun/multi-dboard-load-all.scm ================================================================== --- tests/fullrun/multi-dboard-load-all.scm +++ /dev/null @@ -1,13 +0,0 @@ - -(require-library margs) -(load "../../common.scm") -(load "../../common_records.scm") -(load "../../margs.scm") -(load "../../megatest-version.scm") -(load "../../portlogger.scm") -(load "../../tasks.scm") -(load "../../db.scm") -(load "../../configf.scm") -(load "../../keys.scm") -(load "../../tree.scm") -(load "../../multi-dboard.scm") DELETED tests/fullrun/multi-dboard.sh Index: tests/fullrun/multi-dboard.sh ================================================================== --- tests/fullrun/multi-dboard.sh +++ /dev/null @@ -1,30 +0,0 @@ -#!/bin/bash - -if [[ ! -e "$HOME/.megatest" ]];then - mkdir -p "$HOME/.megatest" -fi -# if [[ ! -e "$HOME/.megatest/areas.dat" ]];then -# echo "Creating some placeholder files in ~/.megatest" -# cat > "$HOME/.megatest/areas.dat" << EOF -# [default] -# mfstest /mfs/matt/data/megatest/tests/fullrun -# mfsbig /mfs/matt/data/megatest/tests/fdktestqa/testqa -# [local] -# localtest /home/matt/data/megatest/tests/fullrun -# EOF -# fi -if [[ ! -e "$HOME/.megatest/default.dat" ]];then - cat > "$HOME/.megatest/default.dat" << EOF -[fullrun] -path /mfs/matt/data/megatest/tests/fullrun -order 1 -# [bigrun] -# path /mfs/matt/data/megatest/tests/fdktestqa/testqa -# order 2 -# [local_fullrun] -# path /home/matt/data/megatest/tests/fullrun -# order 3 -EOF -fi - -csi -I ../.. multi-dboard-load-all.scm DELETED tests/fullrun/nfs.config Index: tests/fullrun/nfs.config ================================================================== --- tests/fullrun/nfs.config +++ /dev/null @@ -1,1 +0,0 @@ -TESTSTORUN priority_4 test_mt_vars DELETED tests/fullrun/run-each-proc.sh Index: tests/fullrun/run-each-proc.sh ================================================================== --- tests/fullrun/run-each-proc.sh +++ /dev/null @@ -1,15 +0,0 @@ -#!/bin/bash - -for x in `cat all-db-procs.txt`;do - cat > ~/.megatestrc <' '-_g'` - megatest -runtests sqlitespeed,test2,ez% -target ubuntu/nfs/none :runname $fname > $fname.log -done - - DELETED tests/fullrun/runconfigs.config Index: tests/fullrun/runconfigs.config ================================================================== --- tests/fullrun/runconfigs.config +++ /dev/null @@ -1,48 +0,0 @@ -[default] -SOMEVAR This should show up in SOMEVAR3 -VARNOVAL -VARNOVAL_WITHSPACE - -# target based getting of config file, look at afs.config and nfs.config -[include #{getenv fsname}.config] - -[include #{getenv MT_RUN_AREA_HOME}/common_runconfigs.config] - -# #{system echo 'VACKYVAR #{shell pwd}' > $MT_RUN_AREA_HOME/configs/$USER.config} -[include ./configs/#{getenv USER}.config] - - -WACKYVAR0 #{get ubuntu/nfs/none CURRENT} -WACKYVAR1 #{scheme (args:get-arg "-target")} - -[default/ubuntu/nfs] -WACKYVAR2 #{runconfigs-get CURRENT} - -[ubuntu/nfs/none] -WACKYVAR2 #{runconfigs-get CURRENT} -SOMEVAR2 This should show up in SOMEVAR4 if the target is ubuntu/nfs/none -VARWITHDOLLARSIGNS The$USER/signs/should/be/replaced/with/variable - -[default] -SOMEVAR3 #{rget SOMEVAR} -SOMEVAR4 #{rget SOMEVAR2} -SOMEVAR5 #{runconfigs-get SOMEVAR2} - -[ubuntu/nfs/all_toplevel] -TESTPATT all_toplevel - -[this/a/test] -BLAHFOO 123 - -[ubuntu/nfs/sleep1] -SLEEPRUNNER 1 - -[ubuntu/nfs/sleep10] -SLEEPRUNNER 10 - -[ubuntu/nfs/sleep60] -SLEEPRUNNER 60 - -[ubuntu/nfs/sleep240] -SLEEPRUNNER 240 - DELETED tests/fullrun/tests/all_toplevel/calcresults.logpro Index: tests/fullrun/tests/all_toplevel/calcresults.logpro ================================================================== --- tests/fullrun/tests/all_toplevel/calcresults.logpro +++ /dev/null @@ -1,140 +0,0 @@ -;; (c) 2006,2007,2008,2009 Matthew Welland matt@kiatoa.com -;; -;; License GPL. - -(define logbody "LogFileBody") - -(define pass-specs '( ;; testname num-expected max-runtime - ("exit_0" 1 20) - ("ezlog_fail_then_pass" 1 20) - ("ezlog_pass" 1 20) - ("ez_pass" 1 20) - ("lineitem_pass" 1 20) - ("priority_1" 1 20) - ("priority_10" 1 20) - ("priority_10_waiton_1" 1 20) - ("priority_3" 1 20) - ("priority_4" 1 20) - ;; ("priority_5" 1 20) - ("priority_6" 1 20) -;; ("priority_7" 1 20) - ("priority_8" 1 20) - ("priority_9" 1 20) - ("runfirst" 7 20) - ("singletest" 1 20) - ("singletest2" 1 20) - ("special" 1 20) - ("sqlitespeed" 10 20) - ("test1" 1 20) - ("test2" 6 20) - ("test_mt_vars" 6 20) - )) - -(define fail-specs '( ;; testname num-expected max-runtime - ("exit_1" 1 20) - ("ez_exit2_fail" 1 20) - ("ez_fail" 1 20) - ("ez_fail_quick" 1 20) - ("ezlog_fail" 1 20) - ("lineitem_fail" 1 20) - ("logpro_required_fail" 1 20) - ("manual_example" 1 20) - ("neverrun" 1 20))) - -(define warn-specs '(("ezlog_warn" 1 20))) - -(define nost-specs '(("wait_no_items1" 1 20) - ("wait_no_items2" 1 20) - ("wait_no_items3" 1 20) - ("wait_no_items4" 1 20) - ;; ("no_items" 1 20) - )) - -(define (check-one-test estate estatus testname count runtime) - (let* ((rxe (regexp (conc "^\\s+Test: " testname "(\\(.*|\\s+)\\s+State: " estate "\\s+Status: " estatus "\\s+Runtime:\\s+(\\d+)s"))) - (msg1 (conc testname " expecting count of " count)) - (msg2 (conc testname " expecting runtime less than " runtime))) - (expect:required in logbody = count msg1 rxe) - ;;(expect:value in logbody count < msg2 rxe) - )) - -;; Special cases -;; -(expect:ignore in logbody >= 0 "db_sync test might not have run" #/Test: db_sync/) -(expect:ignore in logbody >= 0 "all_toplevel may not yet be done" #/Test: all_toplevel/) -(expect:error in logbody = 0 "tests left in RUNNING state" #/State: RUNNING/) -(expect:required in logbody = 1 "priority_2 is KILLED" #/Test: priority_2\s+State: KILLED\s+Status: KILLED/) -(expect:required in logbody = 1 "priority_5 is either PASS or SKIP" #/Test: priority_5\s+State: COMPLETED\s+Status: (SKIP|PASS)/) -(expect:required in logbody = 1 "priority_7 is either PASS or SKIP" #/Test: priority_7\s+State: COMPLETED\s+Status: (SKIP|PASS)/) -(expect:required in logbody = 1 "testxz has 1 NOT_STARTED test" #/Test: testxz\s+State: NOT_STARTED/) -(expect:required in logbody = 1 "no items" #/Test: no_items\s+State: NOT_STARTED\s+Status: ZERO_ITEMS/) -(expect:warning in logbody = 1 "dynamic waiton" #/Test: dynamic_waiton/) -(expect:required in logbody = 29 "blocktestxz has 29 tests" #/Test: blocktestxz/) - -;; General cases -;; -(for-each - (lambda (testdat) - (apply check-one-test "COMPLETED" "PASS" testdat)) - pass-specs) - -(for-each - (lambda (testdat) - (apply check-one-test "COMPLETED" "FAIL" testdat)) - fail-specs) - -(for-each - (lambda (testdat) - (apply check-one-test "COMPLETED" "WARN" testdat)) - warn-specs) - -(for-each - (lambda (testdat) - (apply check-one-test "NOT_STARTED" "PREQ_DISCARDED" testdat)) - nost-specs) - -;; Catch all. -;; -(expect:error in logbody = 0 "Tests not accounted for" #/Test: /) - - -;; ;; define your hooks -;; (hook:first-error "echo \"Error hook activated: #{escaped errmsg}\"") -;; (hook:first-warning "echo \"Got warning: #{escaped warnmsg}\"") -;; (hook:value "echo \"Value hook activated: expected=#{expected}, measured=#{measured}, tolerance=#{tolerance}, message=#{message}\"") -;; -;; ;; first ensure your run at least started -;; ;; -;; (trigger "Init" #/This is a header/) -;; (trigger "InitEnd" #/^\s*$/) -;; (section "Init" "Init" "InitEnd") -;; -;; (trigger "Body" #/^.*$/) ;; anything starts the body -;; ;; (trigger "EndBody" #/This had better never match/) -;; -;; (section "Body" "Body" "EndBody") -;; -;; (trigger "Blah2" #/^begin Blah2/) -;; (trigger "Blah2End" #/^end Blah2/) -;; (section "Blah2" "Blah2" "Blah2End") -;; -;; (expect:required in "Init" = 1 "Header" #/This is a header/) -;; (expect:required in "LogFileBody" > 0 "Something required but not found" #/This is required but not found/) -;; (expect:value in "LogFileBody" 1.9 0.1 "Output voltage" #/Measured voltage output:\s*([\d\.\+\-e]+)v/) -;; (expect:value in "LogFileBody" 0.5 0.1 "Output current" #/Measured output current:\s*([\d\.\+\-e]+)mA/) -;; (expect:value in "LogFileBody" 110e9 2e9 "A big number (first)" #/Freq:\s*([\d\.\+\-e]+)\s+Hz/) -;; (expect:value in "LogFileBody" 110e9 1e9 "A big number (second), hook not called" #/Freq:\s*([\d\.\+\-e]+)Hz/) -;; (expect:value in "LogFileBody" 110e9 1e9 "A big number (never activated)" #/Freq:\s*([\d\.\+\-e]+)zH/) -;; -;; ;; Using match number -;; (expect:value in "LogFileBody" 1.9 0.1 "Time Voltage" #/out: (\d+)\s+(\d+)/ match: 2) -;; -;; ;; Comparison instead of tolerance -;; (expect:value in "LogFileBody" 1.9 > "Time voltage" #/out: (\d+)\s+(\d+)/ match: 2) -;; -;; (expect:ignore in "Blah2" < 99 "FALSE ERROR" #/ERROR/) -;; (expect:ignore in "Body" < 99 "Ignore the word error in comments" #/^\/\/.*error/) -;; (expect:warning in "Body" = 0 "Any warning" #/WARNING/) -;; (expect:error in "Body" = 0 "ERROR BLAH" (list #/ERROR/ #/error/)) ;; but disallow any other errors -;; -;; ;(expect in "Init" < 1 "Junk" #/This is bogus/) DELETED tests/fullrun/tests/all_toplevel/testconfig Index: tests/fullrun/tests/all_toplevel/testconfig ================================================================== --- tests/fullrun/tests/all_toplevel/testconfig +++ /dev/null @@ -1,13 +0,0 @@ -[ezsteps] -calcresults megatest -list-runs $MT_RUNNAME -target $MT_TARGET -check_triggers cat $MT_RUN_AREA_HOME/triggers_$MT_RUN_NAME.dat - -[logpro] -check_triggers ;; - (expect:error in "LogFileBody" = 0 "No errors" #/error/i) - -[requirements] -waiton #{getenv ALL_TOPLEVEL_TESTS} - -# This is a "toplevel" test, it does not require waitons to be non-FAIL to run -mode toplevel DELETED tests/fullrun/tests/blocktestxz/main.sh Index: tests/fullrun/tests/blocktestxz/main.sh ================================================================== --- tests/fullrun/tests/blocktestxz/main.sh +++ /dev/null @@ -1,6 +0,0 @@ -#!/bin/bash - -$MT_MEGATEST -test-status :state $THESTATE :status $THESTATUS -setlog "nada.html" - -# By exiting with non-zero we tell Megatest to preseve the state and status -exit 1 DELETED tests/fullrun/tests/blocktestxz/testconfig Index: tests/fullrun/tests/blocktestxz/testconfig ================================================================== --- tests/fullrun/tests/blocktestxz/testconfig +++ /dev/null @@ -1,22 +0,0 @@ -[setup] -runscript main.sh - -[items] -THESTATE UNKNOWN INCOMPLETE KILLED KILLREQ STUCK BOZZLEBLONKED STUCK/DEAD -THESTATUS PASS FAIL STUCK/DEAD SKIP - -[requirements] -waiton sqlitespeed - -[test_meta] -author matt -owner bob -description This test will fail causing the dependent test "testxz"\ - to never run. This triggers the code that must determine\ - that a test will never be run and thus remove it from\ - the queue of tests to be run. - -tags first,single -reviewed 1/1/1965 - -jobgroup blockz DELETED tests/fullrun/tests/db_sync/calcresults.logpro Index: tests/fullrun/tests/db_sync/calcresults.logpro ================================================================== --- tests/fullrun/tests/db_sync/calcresults.logpro +++ /dev/null @@ -1,44 +0,0 @@ -;; (c) 2006,2007,2008,2009 Matthew Welland matt@kiatoa.com -;; -;; License GPL. - -;; ;; define your hooks -;; (hook:first-error "echo \"Error hook activated: #{escaped errmsg}\"") -;; (hook:first-warning "echo \"Got warning: #{escaped warnmsg}\"") -;; (hook:value "echo \"Value hook activated: expected=#{expected}, measured=#{measured}, tolerance=#{tolerance}, message=#{message}\"") -;; -;; ;; first ensure your run at least started -;; ;; -;; (trigger "Init" #/This is a header/) -;; (trigger "InitEnd" #/^\s*$/) -;; (section "Init" "Init" "InitEnd") -;; -;; (trigger "Body" #/^.*$/) ;; anything starts the body -;; ;; (trigger "EndBody" #/This had better never match/) -;; -;; (section "Body" "Body" "EndBody") -;; -;; (trigger "Blah2" #/^begin Blah2/) -;; (trigger "Blah2End" #/^end Blah2/) -;; (section "Blah2" "Blah2" "Blah2End") -;; -;; (expect:required in "Init" = 1 "Header" #/This is a header/) -;; (expect:required in "LogFileBody" > 0 "Something required but not found" #/This is required but not found/) -;; (expect:value in "LogFileBody" 1.9 0.1 "Output voltage" #/Measured voltage output:\s*([\d\.\+\-e]+)v/) -;; (expect:value in "LogFileBody" 0.5 0.1 "Output current" #/Measured output current:\s*([\d\.\+\-e]+)mA/) -;; (expect:value in "LogFileBody" 110e9 2e9 "A big number (first)" #/Freq:\s*([\d\.\+\-e]+)\s+Hz/) -;; (expect:value in "LogFileBody" 110e9 1e9 "A big number (second), hook not called" #/Freq:\s*([\d\.\+\-e]+)Hz/) -;; (expect:value in "LogFileBody" 110e9 1e9 "A big number (never activated)" #/Freq:\s*([\d\.\+\-e]+)zH/) -;; -;; ;; Using match number -;; (expect:value in "LogFileBody" 1.9 0.1 "Time Voltage" #/out: (\d+)\s+(\d+)/ match: 2) -;; -;; ;; Comparison instead of tolerance -;; (expect:value in "LogFileBody" 1.9 > "Time voltage" #/out: (\d+)\s+(\d+)/ match: 2) -;; -;; (expect:ignore in "Blah2" < 99 "FALSE ERROR" #/ERROR/) -;; (expect:ignore in "Body" < 99 "Ignore the word error in comments" #/^\/\/.*error/) -;; (expect:warning in "Body" = 0 "Any warning" #/WARNING/) -;; (expect:error in "Body" = 0 "ERROR BLAH" (list #/ERROR/ #/error/)) ;; but disallow any other errors -;; -;; ;(expect in "Init" < 1 "Junk" #/This is bogus/) DELETED tests/fullrun/tests/db_sync/dbdelta.scm Index: tests/fullrun/tests/db_sync/dbdelta.scm ================================================================== --- tests/fullrun/tests/db_sync/dbdelta.scm +++ /dev/null @@ -1,44 +0,0 @@ - -(use sql-de-lite) - -(define megatest.db (conc (get-environment-variable "MT_RUN_AREA_HOME") "/megatest.db")) - -(define runsquery "sysname||'/'||fsname||'/'||datapath||'/'||runname||'/'||runs.state||'-'||runs.status") -(define bigquery - (conc - "SELECT " runsquery "||testname||'/'||item_path||'-'||'-'||tests.state||'-'||tests.status||'-'||runs.id AS outdat FROM runs INNER JOIN tests ON runs.id=tests.run_id WHERE runs.state NOT LIKE 'deleted' AND tests.state NOT LIKE 'deleted' AND testname NOT LIKE 'db_sync' ORDER BY outdat ASC ;")) - -(print "Creating file for legacy db") -(with-output-to-file "legacy-db-dump" - (lambda () - (let ((db (open-database megatest.db))) - (query (for-each-row - (lambda (res) - (print res))) - (sql db bigquery)) - (close-database db)))) - -(define main.db (conc (get-environment-variable "MT_DBDIR") "/main.db")) - -(print "Creating file for current db") -(with-output-to-file "current-db-dump" - (lambda () - (let* ((mdb (open-database main.db)) - (run-ids (query fetch-column (sql mdb (conc "select id," runsquery " AS rq from runs ORDER BY rq ASC;")))) - (dbdir (get-environment-variable "MT_DBDIR"))) - (for-each - (lambda (rid) - (let ((dbfile (conc dbdir "/" rid ".db"))) - (if (file-exists? dbfile) - (begin - (exec (sql mdb (conc "ATTACH DATABASE '" dbfile "' AS testsdb;"))) - (query (for-each-row - (lambda (res) - (print res))) - (sql mdb bigquery)) - (exec (sql mdb "DETACH DATABASE testsdb;"))) - (print "ERROR: No file " dbfile " found")))) - run-ids) - (close-database mdb)))) - - DELETED tests/fullrun/tests/db_sync/getdbdir.scm Index: tests/fullrun/tests/db_sync/getdbdir.scm ================================================================== --- tests/fullrun/tests/db_sync/getdbdir.scm +++ /dev/null @@ -1,1 +0,0 @@ -(db:dbfile-path #f) DELETED tests/fullrun/tests/db_sync/showdiff.logpro Index: tests/fullrun/tests/db_sync/showdiff.logpro ================================================================== --- tests/fullrun/tests/db_sync/showdiff.logpro +++ /dev/null @@ -1,46 +0,0 @@ -;; (c) 2006,2007,2008,2009 Matthew Welland matt@kiatoa.com -;; -;; License GPL. - -;; ;; define your hooks -;; (hook:first-error "echo \"Error hook activated: #{escaped errmsg}\"") -;; (hook:first-warning "echo \"Got warning: #{escaped warnmsg}\"") -;; (hook:value "echo \"Value hook activated: expected=#{expected}, measured=#{measured}, tolerance=#{tolerance}, message=#{message}\"") -;; -;; ;; first ensure your run at least started -;; ;; -;; (trigger "Init" #/This is a header/) -;; (trigger "InitEnd" #/^\s*$/) -;; (section "Init" "Init" "InitEnd") -;; -;; (trigger "Body" #/^.*$/) ;; anything starts the body -;; ;; (trigger "EndBody" #/This had better never match/) -;; -;; (section "Body" "Body" "EndBody") -;; -;; (trigger "Blah2" #/^begin Blah2/) -;; (trigger "Blah2End" #/^end Blah2/) -;; (section "Blah2" "Blah2" "Blah2End") -;; -;; (expect:required in "Init" = 1 "Header" #/This is a header/) -;; (expect:required in "LogFileBody" > 0 "Something required but not found" #/This is required but not found/) -;; (expect:value in "LogFileBody" 1.9 0.1 "Output voltage" #/Measured voltage output:\s*([\d\.\+\-e]+)v/) -;; (expect:value in "LogFileBody" 0.5 0.1 "Output current" #/Measured output current:\s*([\d\.\+\-e]+)mA/) -;; (expect:value in "LogFileBody" 110e9 2e9 "A big number (first)" #/Freq:\s*([\d\.\+\-e]+)\s+Hz/) -;; (expect:value in "LogFileBody" 110e9 1e9 "A big number (second), hook not called" #/Freq:\s*([\d\.\+\-e]+)Hz/) -;; (expect:value in "LogFileBody" 110e9 1e9 "A big number (never activated)" #/Freq:\s*([\d\.\+\-e]+)zH/) -;; -;; ;; Using match number -;; (expect:value in "LogFileBody" 1.9 0.1 "Time Voltage" #/out: (\d+)\s+(\d+)/ match: 2) -;; -;; ;; Comparison instead of tolerance -;; (expect:value in "LogFileBody" 1.9 > "Time voltage" #/out: (\d+)\s+(\d+)/ match: 2) -;; -;; (expect:ignore in "Blah2" < 99 "FALSE ERROR" #/ERROR/) -;; (expect:ignore in "Body" < 99 "Ignore the word error in comments" #/^\/\/.*error/) -;; (expect:warning in "Body" = 0 "Any warning" #/WARNING/) -;; (expect:error in "Body" = 0 "ERROR BLAH" (list #/ERROR/ #/error/)) ;; but disallow any other errors -;; -;; ;(expect in "Init" < 1 "Junk" #/This is bogus/) - -(expect:error in "LogFileBody" = 0 "Any diff is failure" #/.+/) DELETED tests/fullrun/tests/db_sync/testconfig Index: tests/fullrun/tests/db_sync/testconfig ================================================================== --- tests/fullrun/tests/db_sync/testconfig +++ /dev/null @@ -1,13 +0,0 @@ -[pre-launch-env-vars] - -MT_DBDIR #{scheme (db:dbfile-path #f)} - -[ezsteps] -calcresults csi -b dbdelta.scm -showdiff diff current-db-dump legacy-db-dump - -[requirements] -waiton #{getenv ALL_TOPLEVEL_TESTS} - -# This is a "toplevel" test, it does not require waitons to be non-FAIL to run -mode toplevel DELETED tests/fullrun/tests/dynamic_waiton/testconfig Index: tests/fullrun/tests/dynamic_waiton/testconfig ================================================================== --- tests/fullrun/tests/dynamic_waiton/testconfig +++ /dev/null @@ -1,21 +0,0 @@ -[ezsteps] -listfiles ls - -[requirements] -waiton #{scheme (string-intersperse \ - (tests:filter-test-names \ - (hash-table-keys (tests:get-all)) \ - (or (args:get-arg "-runtests") \ - (args:get-arg "-testpatt") "")) " ")} - -[items] - -[test_meta] -author matt -owner bob -description This test runs a single ezstep which is expected to pass \ -but there is an items definition with no items. This should evoke an \ -error. - -tags first,single -reviewed 09/10/2011, by Matt DELETED tests/fullrun/tests/exit_0/main.sh Index: tests/fullrun/tests/exit_0/main.sh ================================================================== --- tests/fullrun/tests/exit_0/main.sh +++ /dev/null @@ -1,10 +0,0 @@ -#!/bin/bash - -# a bunch of steps in 2 second increments -for i in 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17;do - $MT_MEGATEST -step step$i :state start :status running -setlog results$i.html - sleep 2 - $MT_MEGATEST -step step$i :state end :status 0 -done - -exit 0 DELETED tests/fullrun/tests/exit_0/testconfig Index: tests/fullrun/tests/exit_0/testconfig ================================================================== --- tests/fullrun/tests/exit_0/testconfig +++ /dev/null @@ -1,17 +0,0 @@ -[setup] -runscript main.sh - -[test_meta] -author matt -owner bob -description This test checks that a multi-lineitem test with mix of pass and non-fail rolls up a PASS - -tags first,single -reviewed 09/10/2011, by Matt - -[triggers] -# NOT_STARTED/ xterm -e bash -s -- -NOT_STARTED/ echo "trigger: exit_0, NOT_STARTED/" > $MT_RUN_AREA_HOME/triggers_$MT_RUN_NAME.dat -RUNNING/ echo "trigger: exit_0, RUNNING/" >> $MT_RUN_AREA_HOME/triggers_$MT_RUN_NAME.dat - - DELETED tests/fullrun/tests/exit_1/main.sh Index: tests/fullrun/tests/exit_1/main.sh ================================================================== --- tests/fullrun/tests/exit_1/main.sh +++ /dev/null @@ -1,10 +0,0 @@ -#!/bin/bash - -# a bunch of steps in 2 second increments -for i in 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17;do - $MT_MEGATEST -step step$i :state start :status running -setlog results$i.html - sleep 2 - $MT_MEGATEST -step step$i :state end :status 0 -done - -exit 1 DELETED tests/fullrun/tests/exit_1/testconfig Index: tests/fullrun/tests/exit_1/testconfig ================================================================== --- tests/fullrun/tests/exit_1/testconfig +++ /dev/null @@ -1,13 +0,0 @@ -[setup] -runscript main.sh - -[requirements] -priority 9 - -[test_meta] -author matt -owner bob -description This test checks that a multi-lineitem test with mix of pass and non-fail rolls up a PASS - -tags first,single -reviewed 09/10/2011, by Matt DELETED tests/fullrun/tests/ez_exit2_fail/testconfig Index: tests/fullrun/tests/ez_exit2_fail/testconfig ================================================================== --- tests/fullrun/tests/ez_exit2_fail/testconfig +++ /dev/null @@ -1,15 +0,0 @@ -[setup] - -[ezsteps] -exit2 exit 2 -lookithome ls /home - -[test_meta] -author matt -owner bob -description This test runs two steps; the first exits with\ - code 2 (a fail because not using logpro) and the second\ - is a pass - -tags first,single -reviewed 09/10/2011, by Matt DELETED tests/fullrun/tests/ez_fail/testconfig Index: tests/fullrun/tests/ez_fail/testconfig ================================================================== --- tests/fullrun/tests/ez_fail/testconfig +++ /dev/null @@ -1,19 +0,0 @@ -[setup] - -[requirements] -priority 10 - -[ezsteps] -lookittmp sleep 5s;ls /tmp -lookithome sleep 2;ls /home -# should fail on next step -lookitnada sleep 3;ls /nada -lookitusr sleep 2;ls /usr - -[test_meta] -author matt -owner bob -description This test runs a single ezstep which is expected to pass, no logpro file. - -tags first,single -reviewed 09/10/2011, by Matt DELETED tests/fullrun/tests/ez_fail_quick/testconfig Index: tests/fullrun/tests/ez_fail_quick/testconfig ================================================================== --- tests/fullrun/tests/ez_fail_quick/testconfig +++ /dev/null @@ -1,18 +0,0 @@ -[requirements] -priority 10 - -[ezsteps] -# should fail on next step -lookitnada ls /nada - -[triggers] -# run like this: cmd test-id test-rundir trigger -COMPLETED/FAIL echo "trigger: ez_fail_quick, COMPLETED/FAIL" >> $MT_RUN_AREA_HOME/triggers_$MT_RUN_NAME.dat - -[test_meta] -author matt -owner bob -description This test runs a single ezstep which fails immediately. - -tags first,single -reviewed 09/10/2011, by Matt DELETED tests/fullrun/tests/ez_pass/testconfig Index: tests/fullrun/tests/ez_pass/testconfig ================================================================== --- tests/fullrun/tests/ez_pass/testconfig +++ /dev/null @@ -1,15 +0,0 @@ -[setup] - -[ezsteps] -lookittmp sleep 1;ls /tmp -lookithome sleep 1;ls /home -isrunname1 sleep 1;echo $MYRUNNAME1 | grep -v '#f' -isrunname2 sleep 1;echo $MYRUNNAME2 | grep -v '#f' - -[test_meta] -author matt -owner bob -description This test runs a single ezstep which is expected to pass, no logpro file. - -tags first,single -reviewed 09/10/2011, by Matt DELETED tests/fullrun/tests/ez_pass_linked Index: tests/fullrun/tests/ez_pass_linked ================================================================== --- tests/fullrun/tests/ez_pass_linked +++ /dev/null @@ -1,1 +0,0 @@ -../ez_pass_linked/ DELETED tests/fullrun/tests/ezlog_fail/example.logpro Index: tests/fullrun/tests/ezlog_fail/example.logpro ================================================================== --- tests/fullrun/tests/ezlog_fail/example.logpro +++ /dev/null @@ -1,44 +0,0 @@ -;; (c) 2006,2007,2008,2009 Matthew Welland matt@kiatoa.com -;; -;; License GPL. - -;; define your hooks -(hook:first-error "echo \"Error hook activated: #{escaped errmsg}\"") -(hook:first-warning "echo \"Got warning: #{escaped warnmsg}\"") -(hook:value "echo \"Value hook activated: expected=#{expected}, measured=#{measured}, tolerance=#{tolerance}, message=#{message}\"") - -;; first ensure your run at least started -;; -(trigger "Init" #/This is a header/) -(trigger "InitEnd" #/^\s*$/) -(section "Init" "Init" "InitEnd") - -(trigger "Body" #/^.*$/) ;; anything starts the body -;; (trigger "EndBody" #/This had better never match/) - -(section "Body" "Body" "EndBody") - -(trigger "Blah2" #/^begin Blah2/) -(trigger "Blah2End" #/^end Blah2/) -(section "Blah2" "Blah2" "Blah2End") - -(expect:required in "Init" = 1 "Header" #/This is a header/) -(expect:required in "LogFileBody" > 0 "Something required but not found" #/This is required but not found/) -(expect:value in "LogFileBody" 1.9 0.1 "Output voltage" #/Measured voltage output:\s*([\d\.\+\-e]+)v/) -(expect:value in "LogFileBody" 0.5 0.1 "Output current" #/Measured output current:\s*([\d\.\+\-e]+)mA/) -(expect:value in "LogFileBody" 110e9 2e9 "A big number (first)" #/Freq:\s*([\d\.\+\-e]+)\s+Hz/) -(expect:value in "LogFileBody" 110e9 1e9 "A big number (second), hook not called" #/Freq:\s*([\d\.\+\-e]+)Hz/) -(expect:value in "LogFileBody" 110e9 1e9 "A big number (never activated)" #/Freq:\s*([\d\.\+\-e]+)zH/) - -;; Using match number -(expect:value in "LogFileBody" 1.9 0.1 "Time Voltage" #/out: (\d+)\s+(\d+)/ match: 2) - -;; Comparison instead of tolerance -(expect:value in "LogFileBody" 1.9 > "Time voltage" #/out: (\d+)\s+(\d+)/ match: 2) - -(expect:ignore in "Blah2" < 99 "FALSE ERROR" #/ERROR/) -(expect:ignore in "Body" < 99 "Ignore the word error in comments" #/^\/\/.*error/) -(expect:warning in "Body" = 0 "Any warning" #/WARNING/) -(expect:error in "Body" = 0 "ERROR BLAH" (list #/ERROR/ #/error/)) ;; but disallow any other errors - -;(expect in "Init" < 1 "Junk" #/This is bogus/) DELETED tests/fullrun/tests/ezlog_fail/lookithome.logpro Index: tests/fullrun/tests/ezlog_fail/lookithome.logpro ================================================================== --- tests/fullrun/tests/ezlog_fail/lookithome.logpro +++ /dev/null @@ -1,10 +0,0 @@ -;; (c) 2006,2007,2008,2009 Matthew Welland matt@kiatoa.com -;; -;; License GPL. - - -(expect:required in "LogFileBody" > 0 "Must be some files in the dir" #/.*/) - -(expect:ignore in "LogFileBody" < 99 "Ignore the word error in comments" #/^\/\/.*error/) -(expect:warning in "LogFileBody" = 0 "Any warning" #/WARNING/) -(expect:error in "LogFileBody" = 0 "Any error" (list #/ERROR/ #/error/)) ;; but disallow any other errors DELETED tests/fullrun/tests/ezlog_fail/lookittmp.logpro Index: tests/fullrun/tests/ezlog_fail/lookittmp.logpro ================================================================== --- tests/fullrun/tests/ezlog_fail/lookittmp.logpro +++ /dev/null @@ -1,6 +0,0 @@ -;; (c) 2006,2007,2008,2009 Matthew Welland matt@kiatoa.com -;; -;; License GPL. - -(expect:warning in "LogFileBody" = 0 "Any warning" #/WARNING/) -(expect:error in "LogFileBody" = 0 "Any error" (list #/ERROR/ #/.*/)) ;; force an error DELETED tests/fullrun/tests/ezlog_fail/testconfig Index: tests/fullrun/tests/ezlog_fail/testconfig ================================================================== --- tests/fullrun/tests/ezlog_fail/testconfig +++ /dev/null @@ -1,28 +0,0 @@ -[setup] - -[ezsteps] -lookittmp ls /tmp -lookithome ls /home - -# logpro_file input_glob -# matching file(s) will be diff'd with previous run and logpro applied -# if PASS or WARN result from logpro then WAIVER state is set -# -[waivers] -waiver_1 logpro lookittmp.log - -[waiver_rules] - -# This builtin rule is the default if there is no .logpro file -# diff diff %file1% %file2% - -# This builtin rule is applied if a .logpro file exists -# logpro diff %file1% %file2% | logpro %waivername%.logpro %waivername%.html - -[test_meta] -author matt -owner bob -description This test runs two ezstep, the first of which is expected to fail using a simple logpro file. - -tags first,single -reviewed 09/10/2011, by Matt DELETED tests/fullrun/tests/ezlog_fail/waiver_1.logpro Index: tests/fullrun/tests/ezlog_fail/waiver_1.logpro ================================================================== --- tests/fullrun/tests/ezlog_fail/waiver_1.logpro +++ /dev/null @@ -1,1 +0,0 @@ -(expect:warning in "Body" = 0 "Any warning" #/WARNING/) DELETED tests/fullrun/tests/ezlog_fail_then_pass/firststep.logpro Index: tests/fullrun/tests/ezlog_fail_then_pass/firststep.logpro ================================================================== --- tests/fullrun/tests/ezlog_fail_then_pass/firststep.logpro +++ /dev/null @@ -1,10 +0,0 @@ -;; (c) 2006,2007,2008,2009 Matthew Welland matt@kiatoa.com -;; -;; License GPL. - - -(expect:required in "LogFileBody" > 0 "Must be some files in the dir" #/.*/) - -(expect:ignore in "LogFileBody" < 99 "Ignore the word error in comments" #/^\/\/.*error/) -(expect:warning in "LogFileBody" = 0 "Any warning" #/WARNING/) -(expect:error in "LogFileBody" = 0 "Any error" (list #/ERROR/ #/error/)) ;; but disallow any other errors DELETED tests/fullrun/tests/ezlog_fail_then_pass/main.sh Index: tests/fullrun/tests/ezlog_fail_then_pass/main.sh ================================================================== --- tests/fullrun/tests/ezlog_fail_then_pass/main.sh +++ /dev/null @@ -1,18 +0,0 @@ -#!/bin/bash - -megatest -step yepstep :state start :status n/a -ls /tmp -megatest -step yepstep :state end :status $? - -megatest -load-test-data << EOF -OPER,du, 1.2, 1.2, < , GBytes ,System didn't use too much space -EOF - -# a bunch of steps in 2 second increments -for i in 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17;do - $MT_MEGATEST -step step$i :state start :status running -setlog results$i.html - sleep 2 - $MT_MEGATEST -step step$i :state end :status 0 -done - -megatest -test-status :state COMPLETED :status AUTO DELETED tests/fullrun/tests/ezlog_fail_then_pass/testconfig Index: tests/fullrun/tests/ezlog_fail_then_pass/testconfig ================================================================== --- tests/fullrun/tests/ezlog_fail_then_pass/testconfig +++ /dev/null @@ -1,13 +0,0 @@ -[setup] - -[ezsteps] -firststep main.sh - -[test_meta] -author matt -owner bob -description This test runs a single ezstep which is logpro clean\ - but fails based on -test-data loaded. - -tags first,single -reviewed 09/10/2011, by Matt DELETED tests/fullrun/tests/ezlog_pass/example.logpro Index: tests/fullrun/tests/ezlog_pass/example.logpro ================================================================== --- tests/fullrun/tests/ezlog_pass/example.logpro +++ /dev/null @@ -1,44 +0,0 @@ -;; (c) 2006,2007,2008,2009 Matthew Welland matt@kiatoa.com -;; -;; License GPL. - -;; define your hooks -(hook:first-error "echo \"Error hook activated: #{escaped errmsg}\"") -(hook:first-warning "echo \"Got warning: #{escaped warnmsg}\"") -(hook:value "echo \"Value hook activated: expected=#{expected}, measured=#{measured}, tolerance=#{tolerance}, message=#{message}\"") - -;; first ensure your run at least started -;; -(trigger "Init" #/This is a header/) -(trigger "InitEnd" #/^\s*$/) -(section "Init" "Init" "InitEnd") - -(trigger "Body" #/^.*$/) ;; anything starts the body -;; (trigger "EndBody" #/This had better never match/) - -(section "Body" "Body" "EndBody") - -(trigger "Blah2" #/^begin Blah2/) -(trigger "Blah2End" #/^end Blah2/) -(section "Blah2" "Blah2" "Blah2End") - -(expect:required in "Init" = 1 "Header" #/This is a header/) -(expect:required in "LogFileBody" > 0 "Something required but not found" #/This is required but not found/) -(expect:value in "LogFileBody" 1.9 0.1 "Output voltage" #/Measured voltage output:\s*([\d\.\+\-e]+)v/) -(expect:value in "LogFileBody" 0.5 0.1 "Output current" #/Measured output current:\s*([\d\.\+\-e]+)mA/) -(expect:value in "LogFileBody" 110e9 2e9 "A big number (first)" #/Freq:\s*([\d\.\+\-e]+)\s+Hz/) -(expect:value in "LogFileBody" 110e9 1e9 "A big number (second), hook not called" #/Freq:\s*([\d\.\+\-e]+)Hz/) -(expect:value in "LogFileBody" 110e9 1e9 "A big number (never activated)" #/Freq:\s*([\d\.\+\-e]+)zH/) - -;; Using match number -(expect:value in "LogFileBody" 1.9 0.1 "Time Voltage" #/out: (\d+)\s+(\d+)/ match: 2) - -;; Comparison instead of tolerance -(expect:value in "LogFileBody" 1.9 > "Time voltage" #/out: (\d+)\s+(\d+)/ match: 2) - -(expect:ignore in "Blah2" < 99 "FALSE ERROR" #/ERROR/) -(expect:ignore in "Body" < 99 "Ignore the word error in comments" #/^\/\/.*error/) -(expect:warning in "Body" = 0 "Any warning" #/WARNING/) -(expect:error in "Body" = 0 "ERROR BLAH" (list #/ERROR/ #/error/)) ;; but disallow any other errors - -;(expect in "Init" < 1 "Junk" #/This is bogus/) DELETED tests/fullrun/tests/ezlog_pass/lookittmp.logpro Index: tests/fullrun/tests/ezlog_pass/lookittmp.logpro ================================================================== --- tests/fullrun/tests/ezlog_pass/lookittmp.logpro +++ /dev/null @@ -1,10 +0,0 @@ -;; (c) 2006,2007,2008,2009 Matthew Welland matt@kiatoa.com -;; -;; License GPL. - - -(expect:required in "LogFileBody" > 0 "Must be some files in the dir" #/.*/) - -(expect:ignore in "LogFileBody" < 99 "Ignore the word error in comments" #/^\/\/.*error/) -(expect:warning in "LogFileBody" = 0 "Any warning" #/WARNING/) -(expect:error in "LogFileBody" = 0 "Any error" (list #/ERROR/ #/error/)) ;; but disallow any other errors DELETED tests/fullrun/tests/ezlog_pass/testconfig Index: tests/fullrun/tests/ezlog_pass/testconfig ================================================================== --- tests/fullrun/tests/ezlog_pass/testconfig +++ /dev/null @@ -1,13 +0,0 @@ -[setup] - -[ezsteps] -lookittmp ls /tmp -lookithome ls /home - -[test_meta] -author matt -owner bob -description This test runs a single ezstep which is expected to pass using a simple logpro file. - -tags first,single -reviewed 09/10/2011, by Matt DELETED tests/fullrun/tests/ezlog_warn/lookithome.logpro Index: tests/fullrun/tests/ezlog_warn/lookithome.logpro ================================================================== --- tests/fullrun/tests/ezlog_warn/lookithome.logpro +++ /dev/null @@ -1,11 +0,0 @@ -;; (c) 2006,2007,2008,2009 Matthew Welland matt@kiatoa.com -;; -;; License GPL. - - -;; Force a warn for this test -(expect:required in "LogFileBody" > 0 "Must be some files in the dir" #/.*/) - -(expect:ignore in "LogFileBody" < 99 "Ignore the word error in comments" #/^\/\/.*error/) -(expect:warning in "LogFileBody" = 0 "Any warning" #/warn/) -(expect:error in "LogFileBody" = 0 "Any error" (list #/ERROR/ #/error/)) ;; but disallow any other errors DELETED tests/fullrun/tests/ezlog_warn/lookittmp.logpro Index: tests/fullrun/tests/ezlog_warn/lookittmp.logpro ================================================================== --- tests/fullrun/tests/ezlog_warn/lookittmp.logpro +++ /dev/null @@ -1,12 +0,0 @@ -;; (c) 2006,2007,2008,2009 Matthew Welland matt@kiatoa.com -;; -;; License GPL. - - -(expect:warning in "LogFileBody" = 0 "Any warning" #/.*/) -;; Can't have a required since it will mask the warns! Could make the warn non-overlapping with the -;; required I suppose... -;; (expect:required in "LogFileBody" > 0 "Must be some files in the dir" #/.*/) - -(expect:ignore in "LogFileBody" < 99 "Ignore the word error in comments" #/^\/\/.*error/) -(expect:error in "LogFileBody" = 0 "Any error" (list #/ERROR/ #/error/)) ;; but disallow any other errors DELETED tests/fullrun/tests/ezlog_warn/testconfig Index: tests/fullrun/tests/ezlog_warn/testconfig ================================================================== --- tests/fullrun/tests/ezlog_warn/testconfig +++ /dev/null @@ -1,13 +0,0 @@ -[setup] - -[ezsteps] -lookittmp ls /tmp -lookithome ls $HOME - -[test_meta] -author matt -owner bob -description This test runs two ezsteps the first of which is expected to fail using a simple logpro file. - -tags first,single -reviewed 09/10/2011, by Matt DELETED tests/fullrun/tests/lineitem_fail/main.sh Index: tests/fullrun/tests/lineitem_fail/main.sh ================================================================== --- tests/fullrun/tests/lineitem_fail/main.sh +++ /dev/null @@ -1,23 +0,0 @@ -#!/bin/bash - -$MT_MEGATEST -load-test-data << EOF -foo,bar, 1.2, 1.9, > -foo,rab, 1.0e9, 10e9, 1e9 -foo,bla, 1.2, 1.9, < -foo,bal, 1.2, 1.2, < , ,Check for overload -foo,alb, 1.2, 1.2, <= , Amps,This is the high power circuit test -foo,abl, 1.2, 1.3, 0.1 -foo,bra, 1.2, pass, silly stuff -faz,bar, 10, 8mA, , ,"this is a comment" -EOF - -# a bunch of steps in 2 second increments -for i in 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17;do - $MT_MEGATEST -step step$i :state start :status running -setlog results$i.html - sleep 2 - $MT_MEGATEST -step step$i :state end :status 0 -done - -# Needed to force rolling up the results and set the test to COMPLETED -$MT_MEGATEST -test-status :state COMPLETED :status AUTO - DELETED tests/fullrun/tests/lineitem_fail/testconfig Index: tests/fullrun/tests/lineitem_fail/testconfig ================================================================== --- tests/fullrun/tests/lineitem_fail/testconfig +++ /dev/null @@ -1,10 +0,0 @@ -[setup] -runscript main.sh - -[test_meta] -author matt -owner bob -description This test checks that a multi-lineitem test with mix of pass and non-fail rolls up a PASS - -tags first,single -reviewed 09/10/2011, by Matt DELETED tests/fullrun/tests/lineitem_pass/main.sh Index: tests/fullrun/tests/lineitem_pass/main.sh ================================================================== --- tests/fullrun/tests/lineitem_pass/main.sh +++ /dev/null @@ -1,22 +0,0 @@ -#!/bin/bash - -# category variable value expected tol/comp units comment -$MT_MEGATEST -load-test-data << EOF -foo, bar, 1.9, 1.8, > -foo, rab, 1.0e9, 2e9, 1e9 -foo, bla, 1.2, 1.9, < -foo, bal, -1.1, 0, < , , Check for overload -foo, alb, 1.2, 1.2, <= , Amps, This is the high power circuit test -foo, abl, 1.2, 1.3, 0.1 -foo, bra, 1.2, pass, silly stuff -faz, bar, 10, 8mA, , ,"this is a comment" -EOF - -# a bunch of steps in 2 second increments -for i in 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17;do - $MT_MEGATEST -step step$i :state start :status running -setlog results$i.html - sleep 2 - $MT_MEGATEST -step step$i :state end :status 0 -done -# Needed to force rolling up the results and set the test to COMPLETED -$MT_MEGATEST -test-status :state COMPLETED :status AUTO DELETED tests/fullrun/tests/lineitem_pass/testconfig Index: tests/fullrun/tests/lineitem_pass/testconfig ================================================================== --- tests/fullrun/tests/lineitem_pass/testconfig +++ /dev/null @@ -1,10 +0,0 @@ -[setup] -runscript main.sh - -[test_meta] -author matt -owner bob -description This test checks that a multi-lineitem test with mix of pass and non-fail rolls up a PASS - -tags first,single -reviewed 09/10/2011, by Matt DELETED tests/fullrun/tests/logpro_required_fail/testconfig Index: tests/fullrun/tests/logpro_required_fail/testconfig ================================================================== --- tests/fullrun/tests/logpro_required_fail/testconfig +++ /dev/null @@ -1,23 +0,0 @@ -[setup] - -[ezsteps] -lookittmp ls /tmp - -[test_meta] -author matt -owner bob -description This test runs two ezstep, the first of which is expected to fail using a simple logpro file. - -[logpro] -lookittmp ;; (c) 2006,2007,2008,2009 Matthew Welland matt@kiatoa.com - ;; - ;; License GPL. - ;; - (expect:required in "LogFileBody" > 0 "A file name that should never exist!" #/This is a awfully stupid file name that should never be found in the temp dir/) - ;; - ;; (expect:warning in "LogFileBody" = 0 "Any warning" #/WARNING/) - ;; (expect:error in "LogFileBody" = 0 "Any error" (list #/ERROR/ #/.*/)) ;; force an error - - -tags logpro -reviewed 09/10/2011, by Matt DELETED tests/fullrun/tests/manual_example/results/results.csv Index: tests/fullrun/tests/manual_example/results/results.csv ================================================================== --- tests/fullrun/tests/manual_example/results/results.csv +++ /dev/null @@ -1,1 +0,0 @@ -category, variable, expected, value, tol, units, comment DELETED tests/fullrun/tests/manual_example/runsetupxterm.sh Index: tests/fullrun/tests/manual_example/runsetupxterm.sh ================================================================== --- tests/fullrun/tests/manual_example/runsetupxterm.sh +++ /dev/null @@ -1,13 +0,0 @@ -#!/bin/bash - -if [[ $TARGETDISPLAY = "" || $TARGETHOST = "" || $TARGETDIR = "" || $TARGETUSER = "" ]]; then - msg="You must set the TARGETDISPLAY, TARGETHOST, TARGETDIR and TARGETUSER variables for manual tests" - echo $msg - megatest -test-status :state COMPLETED :status FAIL -m $msg - exit 1 -else - megatest -step setup :state start :status n/a - xterm -display $TARGETDISPLAY -e ./setupremote.sh - megatest -step setup :state end :status $? -fi - DELETED tests/fullrun/tests/manual_example/setupremote.sh Index: tests/fullrun/tests/manual_example/setupremote.sh ================================================================== --- tests/fullrun/tests/manual_example/setupremote.sh +++ /dev/null @@ -1,28 +0,0 @@ -#!/bin/bash - -megatest -step rsyncto :state start :status n/a -echo "First, lets populate your area with necessary files, you may be prompted for your Unix password several times" -rsync -avz $MT_TEST_RUN_DIR/ $TARGETUSER@$TARGETHOST:$TARGETDIR -megatest -step rsyncto :state end :status n/a - -megatest -step runtest :state start :status n/a -remotecmd="cd $TARGETDIR;xterm -display $TARGETDISPLAY" -echo Launching $remotecmd on $TARGETHOST as $TARGETUSER -ssh $TARGETUSER@$TARGETHOST $remotecmd -megatest -step runtest :state end :status $? - -megatest -step gatherdata :state start :status n/a -rsync -avz $TARGETUSER@$TARGETHOST:$TARGETDIR/results/ $MT_TEST_RUN_DIR/results/ -if [[ -e $MT_TEST_RUN_DIR/results/results.csv ]]; then - megatest -load-test-data < $MT_TEST_RUN_DIR/results/results.csv -fi - -if [[ -e $MT_TEST_RUN_DIR/results/final_results.log && $MT_TEST_RUN_DIR/final_results.logpro ]]; then - logpro $MT_TEST_RUN_DIR/final_results.logpro $MT_TEST_RUN_DIR/final_results.html < $MT_TEST_RUN_DIR/results/final_results.log - if [[ $? = 0 ]]; then - finalstatus=PASS - else - finalstatus=FAIL - fi - megatest -test-status :state COMPLETED :status $finalstatus -setlog final_results.html -fi DELETED tests/fullrun/tests/manual_example/testconfig Index: tests/fullrun/tests/manual_example/testconfig ================================================================== --- tests/fullrun/tests/manual_example/testconfig +++ /dev/null @@ -1,13 +0,0 @@ -[setup] - -[ezsteps] -setup ./runsetupxterm.sh -# launch launchxterm - -[test_meta] -author matt -owner bob -description This test runs a single ezstep which is expected to pass\ - using a simple logpro file. -tags first,single -reviewed 09/10/2011, by Matt DELETED tests/fullrun/tests/neverrun/testconfig Index: tests/fullrun/tests/neverrun/testconfig ================================================================== --- tests/fullrun/tests/neverrun/testconfig +++ /dev/null @@ -1,4 +0,0 @@ -[setup] -runscript idontexist - - DELETED tests/fullrun/tests/no_items/testconfig Index: tests/fullrun/tests/no_items/testconfig ================================================================== --- tests/fullrun/tests/no_items/testconfig +++ /dev/null @@ -1,15 +0,0 @@ -[ezsteps] -listfiles ls - -[items] -FOO - -[test_meta] -author matt -owner bob -description This test runs a single ezstep which is expected to pass \ -but there is an items definition with no items. This should evoke an \ -error. - -tags first,single -reviewed 09/10/2011, by Matt DELETED tests/fullrun/tests/priority_1/main.sh Index: tests/fullrun/tests/priority_1/main.sh ================================================================== --- tests/fullrun/tests/priority_1/main.sh +++ /dev/null @@ -1,10 +0,0 @@ -#!/bin/bash - -# a bunch of steps in 2 second increments -for i in 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17;do - $MT_MEGATEST -step step$i :state start :status running -setlog results$i.html - sleep 2 - $MT_MEGATEST -step step$i :state end :status 0 -done - -exit 0 DELETED tests/fullrun/tests/priority_1/testconfig Index: tests/fullrun/tests/priority_1/testconfig ================================================================== --- tests/fullrun/tests/priority_1/testconfig +++ /dev/null @@ -1,17 +0,0 @@ -[setup] -runscript main.sh - -[requirements] -priority 1 - -[test_meta] -jobgroup sqlite3 -author matt -owner bob -description This test checks that a multi-lineitem test with mix of pass and non-fail rolls up a PASS - -tags first,single -reviewed 09/10/2011, by Matt - -[triggers] -COMPLETED/ echo "trigger: priority_1, COMPLETED/" >> $MT_RUN_AREA_HOME/triggers_$MT_RUN_NAME.dat DELETED tests/fullrun/tests/priority_10/main.sh Index: tests/fullrun/tests/priority_10/main.sh ================================================================== --- tests/fullrun/tests/priority_10/main.sh +++ /dev/null @@ -1,10 +0,0 @@ -#!/bin/bash - -# a bunch of steps in 2 second increments -for i in 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17;do - $MT_MEGATEST -step step$i :state start :status running -setlog results$i.html - sleep 2 - $MT_MEGATEST -step step$i :state end :status 0 -done - -exit 0 DELETED tests/fullrun/tests/priority_10/testconfig Index: tests/fullrun/tests/priority_10/testconfig ================================================================== --- tests/fullrun/tests/priority_10/testconfig +++ /dev/null @@ -1,13 +0,0 @@ -[setup] -runscript main.sh - -[requirements] -priority 10 - -[test_meta] -author matt -owner bob -description This test checks that a multi-lineitem test with mix of pass and non-fail rolls up a PASS - -tags first,single -reviewed 09/10/2011, by Matt DELETED tests/fullrun/tests/priority_10_waiton_1/main.sh Index: tests/fullrun/tests/priority_10_waiton_1/main.sh ================================================================== --- tests/fullrun/tests/priority_10_waiton_1/main.sh +++ /dev/null @@ -1,10 +0,0 @@ -#!/bin/bash - -# a bunch of steps in 2 second increments -for i in 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17;do - $MT_MEGATEST -step step$i :state start :status running -setlog results$i.html - sleep 2 - $MT_MEGATEST -step step$i :state end :status 0 -done - -exit 0 DELETED tests/fullrun/tests/priority_10_waiton_1/testconfig Index: tests/fullrun/tests/priority_10_waiton_1/testconfig ================================================================== --- tests/fullrun/tests/priority_10_waiton_1/testconfig +++ /dev/null @@ -1,14 +0,0 @@ -[setup] -runscript main.sh - -[requirements] -priority 10 -waiton priority_1 - -[test_meta] -author matt -owner bob -description This test checks that a multi-lineitem test with mix of pass and non-fail rolls up a PASS - -tags first,single -reviewed 09/10/2011, by Matt DELETED tests/fullrun/tests/priority_2/main.sh Index: tests/fullrun/tests/priority_2/main.sh ================================================================== --- tests/fullrun/tests/priority_2/main.sh +++ /dev/null @@ -1,10 +0,0 @@ -#!/bin/bash - -# a bunch of steps in 2 second increments -for i in 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17;do - $MT_MEGATEST -step step$i :state start :status running -setlog results$i.html - sleep 5 - $MT_MEGATEST -step step$i :state end :status 0 -done - -exit 0 DELETED tests/fullrun/tests/priority_2/testconfig Index: tests/fullrun/tests/priority_2/testconfig ================================================================== --- tests/fullrun/tests/priority_2/testconfig +++ /dev/null @@ -1,16 +0,0 @@ -[setup] -runscript main.sh - -[requirements] -priority 2 -# runtimelim 1d 1h 1m 10s -runtimelim 20s - -[test_meta] -jobgroup sqlite3 -author matt -owner bob -description This test checks that a multi-lineitem test with mix of pass and non-fail rolls up a PASS - -tags first,single -reviewed 09/10/2011, by Matt DELETED tests/fullrun/tests/priority_3/README Index: tests/fullrun/tests/priority_3/README ================================================================== --- tests/fullrun/tests/priority_3/README +++ /dev/null @@ -1,3 +0,0 @@ -This test used to look for envfile.txt but that file should NOT have been there. - -By changing to lookithome.log it is possible that an error is masked. DELETED tests/fullrun/tests/priority_3/main.sh Index: tests/fullrun/tests/priority_3/main.sh ================================================================== --- tests/fullrun/tests/priority_3/main.sh +++ /dev/null @@ -1,20 +0,0 @@ -#!/bin/bash - -# a bunch of steps in 2 second increments -for i in 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17;do - $MT_MEGATEST -step step$i :state start :status running -setlog results$i.html - sleep 2 - echo "
Results$i
Nothing but faux results here!" > results$i.html - $MT_MEGATEST -step step$i :state end :status 0 -done - -# get a previous test -export EZFAILPATH=`$MT_MEGATEST -test-files lookithome.log -target $MT_TARGET :runname $MT_RUNNAME -testpatt ez_fail` -if [[ -e $EZFAILPATH ]];then - echo All good! -else - echo NOT good! - exit 1 -fi - -exit 0 DELETED tests/fullrun/tests/priority_3/testconfig Index: tests/fullrun/tests/priority_3/testconfig ================================================================== --- tests/fullrun/tests/priority_3/testconfig +++ /dev/null @@ -1,15 +0,0 @@ -[setup] -runscript main.sh - -[requirements] -priority 3 - - -[test_meta] -jobgroup sqlite3 -author matt -owner bob -description This test checks that a multi-lineitem test with mix of pass and non-fail rolls up a PASS - -tags first,single -reviewed 09/10/2011, by Matt DELETED tests/fullrun/tests/priority_4/main.sh Index: tests/fullrun/tests/priority_4/main.sh ================================================================== --- tests/fullrun/tests/priority_4/main.sh +++ /dev/null @@ -1,10 +0,0 @@ -#!/bin/bash - -# a bunch of steps in 2 second increments -for i in 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17;do - $MT_MEGATEST -step step$i :state start :status running -setlog results$i.html - sleep 2 - $MT_MEGATEST -step step$i :state end :status 0 -done - -exit 0 DELETED tests/fullrun/tests/priority_4/testconfig Index: tests/fullrun/tests/priority_4/testconfig ================================================================== --- tests/fullrun/tests/priority_4/testconfig +++ /dev/null @@ -1,14 +0,0 @@ -[setup] -runscript main.sh - -[requirements] -priority 4 - -[test_meta] -jobgroup sqlite3 -author matt -owner bob -description This test checks that a multi-lineitem test with mix of pass and non-fail rolls up a PASS - -tags first,single -reviewed 09/10/2011, by Matt DELETED tests/fullrun/tests/priority_5/main.sh Index: tests/fullrun/tests/priority_5/main.sh ================================================================== --- tests/fullrun/tests/priority_5/main.sh +++ /dev/null @@ -1,10 +0,0 @@ -#!/bin/bash - -# a bunch of steps in 2 second increments -for i in 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17;do - $MT_MEGATEST -step step$i :state start :status running -setlog results$i.html - sleep 2 - $MT_MEGATEST -step step$i :state end :status 0 -done - -exit 0 DELETED tests/fullrun/tests/priority_5/testconfig Index: tests/fullrun/tests/priority_5/testconfig ================================================================== --- tests/fullrun/tests/priority_5/testconfig +++ /dev/null @@ -1,16 +0,0 @@ -[setup] -runscript main.sh - -[requirements] -priority 5 - -[skip] -prevrunning #t - -[test_meta] -author matt -owner bob -description This test checks that a multi-lineitem test with mix of pass and non-fail rolls up a PASS - -tags first,single -reviewed 09/10/2011, by Matt DELETED tests/fullrun/tests/priority_6/main.sh Index: tests/fullrun/tests/priority_6/main.sh ================================================================== --- tests/fullrun/tests/priority_6/main.sh +++ /dev/null @@ -1,10 +0,0 @@ -#!/bin/bash - -# a bunch of steps in 2 second increments -for i in 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17;do - $MT_MEGATEST -step step$i :state start :status running -setlog results$i.html - sleep 2 - $MT_MEGATEST -step step$i :state end :status 0 -done - -exit 0 DELETED tests/fullrun/tests/priority_6/testconfig Index: tests/fullrun/tests/priority_6/testconfig ================================================================== --- tests/fullrun/tests/priority_6/testconfig +++ /dev/null @@ -1,13 +0,0 @@ -[setup] -runscript main.sh - -[requirements] -priority 6 - -[test_meta] -author matt -owner bob -description This test checks that a multi-lineitem test with mix of pass and non-fail rolls up a PASS - -tags first,single -reviewed 09/10/2011, by Matt DELETED tests/fullrun/tests/priority_7/main.sh Index: tests/fullrun/tests/priority_7/main.sh ================================================================== --- tests/fullrun/tests/priority_7/main.sh +++ /dev/null @@ -1,10 +0,0 @@ -#!/bin/bash - -# a bunch of steps in 2 second increments -for i in 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17;do - $MT_MEGATEST -step step$i :state start :status running -setlog results$i.html - sleep 2 - $MT_MEGATEST -step step$i :state end :status 0 -done - -exit 0 DELETED tests/fullrun/tests/priority_7/testconfig Index: tests/fullrun/tests/priority_7/testconfig ================================================================== --- tests/fullrun/tests/priority_7/testconfig +++ /dev/null @@ -1,17 +0,0 @@ -[setup] -runscript main.sh - -[requirements] -priority 7 - -[skip] -# Run only if this much time since last run of this test -rundelay 10m 5s - -[test_meta] -author matt -owner bob -description This test checks that a multi-lineitem test with mix of pass and non-fail rolls up a PASS - -tags first,single -reviewed 09/10/2011, by Matt DELETED tests/fullrun/tests/priority_8/main.sh Index: tests/fullrun/tests/priority_8/main.sh ================================================================== --- tests/fullrun/tests/priority_8/main.sh +++ /dev/null @@ -1,14 +0,0 @@ -#!/bin/bash - -# a bunch of steps in 2 second increments -for i in 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17;do - echo "start step before $i: `date`" - $MT_MEGATEST -step step$i :state start :status running -setlog results$i.html - echo "start step after $i: `date`" - sleep 2 - echo "end step before $i: `date`" - $MT_MEGATEST -step step$i :state end :status 0 - echo "end step after $i: `date`" -done - -exit 0 DELETED tests/fullrun/tests/priority_8/testconfig Index: tests/fullrun/tests/priority_8/testconfig ================================================================== --- tests/fullrun/tests/priority_8/testconfig +++ /dev/null @@ -1,13 +0,0 @@ -[setup] -runscript main.sh - -[requirements] -priority 8 - -[test_meta] -author matt -owner bob -description This test checks that a multi-lineitem test with mix of pass and non-fail rolls up a PASS - -tags first,single -reviewed 09/10/2011, by Matt DELETED tests/fullrun/tests/priority_9/main.sh Index: tests/fullrun/tests/priority_9/main.sh ================================================================== --- tests/fullrun/tests/priority_9/main.sh +++ /dev/null @@ -1,10 +0,0 @@ -#!/bin/bash - -# a bunch of steps in 2 second increments -for i in 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17;do - $MT_MEGATEST -step step$i :state start :status running -setlog results$i.html - sleep 2 - $MT_MEGATEST -step step$i :state end :status 0 -done - -exit 0 DELETED tests/fullrun/tests/priority_9/testconfig Index: tests/fullrun/tests/priority_9/testconfig ================================================================== --- tests/fullrun/tests/priority_9/testconfig +++ /dev/null @@ -1,13 +0,0 @@ -[setup] -runscript main.sh - -[requirements] -priority 9 - -[test_meta] -author matt -owner bob -description This test checks that a multi-lineitem test with mix of pass and non-fail rolls up a PASS - -tags first,single -reviewed 09/10/2011, by Matt DELETED tests/fullrun/tests/runfirst/main.sh Index: tests/fullrun/tests/runfirst/main.sh ================================================================== --- tests/fullrun/tests/runfirst/main.sh +++ /dev/null @@ -1,40 +0,0 @@ -#!/bin/bash - -# (export DISPLAY=:0;xterm) - -# megatest -step wasting_time :state start :status n/a -m "This is a test step comment" -# sleep 20 -# megatest -step wasting_time :state end :status $? - -touch ../I_was_here -mkdir -p $MT_RUN_AREA_HOME/tmp/$USER/$sysname/$fsname/$datapath/$MT_RUNNAME -echo 1 2 3 4 5 > $MT_RUN_AREA_HOME/tmp/$USER/$sysname/$fsname/$datapath/$MT_RUNNAME/the_ans - -$MT_MEGATEST -runstep wasting_time -logpro wasting_time.logpro "sleep 8;echo all done eh?" -m "This is a test step comment" - -$MT_MEGATEST -load-test-data << EOF -foo,bar,1.2,1.9,> -foo,rab,1.0e9,10e9,1e9 -foo,bla,1.2,1.9,< -foo,bal,1.2,1.2,<,,Check for overload -foo,alb,1.2,1.2,<=,Amps,This is the high power circuit test -foo,abl,1.2,1.3,0.1 -foo,bra,1.2,pass,silly stuff -faz,bar,10,8mA,,,"this is a comment" -EOF - -$MT_MEGATEST -load-test-data << EOF -cat, var, val, exp, comp, units, comment, status, type -ameas,iout,1.2,1.9,>,Amps,Comment,,meas -EOF -loadstatus=$? - -if [[ `basename $PWD` == "mustfail" ]];then - $MT_MEGATEST -test-status :state COMPLETED :status FAIL -else - $MT_MEGATEST -test-status :state COMPLETED :status $loadstatus -m "This is a test level comment" :value 10e6 :expected_value 1.1e6 :tol 100e3 :category nada :variable sillyvar :units mFarks :comment "This is the value/expected comment" -fi - -env > envfile.txt - -# $MT_MEGATEST -test-status :state COMPLETED :status FAIL DELETED tests/fullrun/tests/runfirst/testconfig Index: tests/fullrun/tests/runfirst/testconfig ================================================================== --- tests/fullrun/tests/runfirst/testconfig +++ /dev/null @@ -1,24 +0,0 @@ -[setup] -runscript main.sh - -[pre-launch-env-vars] -# These are set before the test is launched on the originating -# host. This can be used to control remote launch tools, e.g. to -# to choose the target host, select the launch tool etc. -SPECIAL_ENV_VAR override with everything after the first space. - -[items] -SEASON summer winter fall spring - -[itemstable] -BLOCK a b -TOCK 1 2 - -[test_meta] -author matt -owner bob -description This test must\ - be run before the other tests - -tags first,single -reviewed 1/1/1965 DELETED tests/fullrun/tests/runfirst/wasting_time.logpro Index: tests/fullrun/tests/runfirst/wasting_time.logpro ================================================================== --- tests/fullrun/tests/runfirst/wasting_time.logpro +++ /dev/null @@ -1,15 +0,0 @@ -;; put stuff here - -;; NOTE: This is not legit logpro code!!! - -;; Test for 0=PASS, 1=WARN, >2 = FAIL - -;; (define season (get-environment-variable "SEASON")) -;; -;; (exit -;; (case (string->symbol season) -;; ((summer) 0) -;; ((winter) 1) -;; ((fall) 2) -;; (else 0))) - DELETED tests/fullrun/tests/singletest/main.sh Index: tests/fullrun/tests/singletest/main.sh ================================================================== --- tests/fullrun/tests/singletest/main.sh +++ /dev/null @@ -1,9 +0,0 @@ -#!/bin/bash - -# megatest -step wasting_time :state start :status n/a -m "This is a test step comment" -# sleep 20 -# megatest -step wasting_time :state end :status $? - -$MT_MEGATEST -runstep wasting_time -logpro wasting_time.logpro "sleep 5;echo alldone" -m "This is a test step comment" - -$MT_MEGATEST -test-status :state COMPLETED :status $? -m "This is a test level comment" -set-toplog the_top_log.html :first_err "This is the first error" DELETED tests/fullrun/tests/singletest/testconfig Index: tests/fullrun/tests/singletest/testconfig ================================================================== --- tests/fullrun/tests/singletest/testconfig +++ /dev/null @@ -1,13 +0,0 @@ -[setup] -runscript main.sh - -[requirements] -diskspace 1M -memory 1G - -[pre-launch-env-vars] -# These are set before the test is launched on the originating -# host. This can be used to control remote launch tools, e.g. to -# to choose the target host, select the launch tool etc. -SPECIAL_ENV_VAR override with everything after the first space. - DELETED tests/fullrun/tests/singletest/wasting_time.logpro Index: tests/fullrun/tests/singletest/wasting_time.logpro ================================================================== --- tests/fullrun/tests/singletest/wasting_time.logpro +++ /dev/null @@ -1,15 +0,0 @@ -;; put stuff here - -;; NOTE: This is not legit logpro code!!! - -;; Test for 0=PASS, 1=WARN, >2 = FAIL - -;; (define season (get-environment-variable "SEASON")) -;; -;; (exit -;; (case (string->symbol season) -;; ((summer) 0) -;; ((winter) 1) -;; ((fall) 2) -;; (else 0))) - DELETED tests/fullrun/tests/singletest2/main.sh Index: tests/fullrun/tests/singletest2/main.sh ================================================================== --- tests/fullrun/tests/singletest2/main.sh +++ /dev/null @@ -1,9 +0,0 @@ -#!/bin/bash - -# megatest -step wasting_time :state start :status n/a -m "This is a test step comment" -# sleep 20 -# megatest -step wasting_time :state end :status $? - -$MT_MEGATEST -runstep wasting_time -logpro wasting_time.logpro "sleep 5;echo all done eh?" -m "This is a test step comment" - -$MT_MEGATEST -test-status :state COMPLETED :status $? -m "This is a test level comment" -set-toplog the_top_log.html :first_warn "This is the first warning" DELETED tests/fullrun/tests/singletest2/testconfig Index: tests/fullrun/tests/singletest2/testconfig ================================================================== --- tests/fullrun/tests/singletest2/testconfig +++ /dev/null @@ -1,14 +0,0 @@ -[setup] -runscript main.sh - -[requirements] -diskspace 1M -memory 1G -waiton singletest - -[pre-launch-env-vars] -# These are set before the test is launched on the originating -# host. This can be used to control remote launch tools, e.g. to -# to choose the target host, select the launch tool etc. -SPECIAL_ENV_VAR override with everything after the first space. - DELETED tests/fullrun/tests/singletest2/wasting_time.logpro Index: tests/fullrun/tests/singletest2/wasting_time.logpro ================================================================== --- tests/fullrun/tests/singletest2/wasting_time.logpro +++ /dev/null @@ -1,15 +0,0 @@ -;; put stuff here - -;; NOTE: This is not legit logpro code!!! - -;; Test for 0=PASS, 1=WARN, >2 = FAIL - -;; (define season (get-environment-variable "SEASON")) -;; -;; (exit -;; (case (string->symbol season) -;; ((summer) 0) -;; ((winter) 1) -;; ((fall) 2) -;; (else 0))) - DELETED tests/fullrun/tests/special/testconfig Index: tests/fullrun/tests/special/testconfig ================================================================== --- tests/fullrun/tests/special/testconfig +++ /dev/null @@ -1,8 +0,0 @@ -[ezsteps] -# calcresults megatest -list-runs $MT_RUNNAME -target $MT_TARGET - -[requirements] -waiton #{rget TESTSTORUN} - -# This is a "toplevel" test, it does not require waitons to be non-FAIL to run -mode toplevel DELETED tests/fullrun/tests/sqlitespeed/runscript.rb Index: tests/fullrun/tests/sqlitespeed/runscript.rb ================================================================== --- tests/fullrun/tests/sqlitespeed/runscript.rb +++ /dev/null @@ -1,38 +0,0 @@ -#! /usr/bin/env ruby - -require "#{ENV['MT_RUN_AREA_HOME']}/../resources/ruby/librunscript.rb" - -# run_record(stepname, cmd) - will record in db if exit code of script was zero or not -run_and_record('create db',"sqlite3 testing.db << EOF\ncreate table if not exists blah(id INTEGER PRIMARY KEY,name TEXT);\n.q\nEOF","") - -if (! File.exists?("../../runfirst/I_was_here")) - puts "ERROR: This test was started before the prerequisites ran!" - system "megatest -test-status :state INCOMPLETE :status FAIL" - exit 1 -end - -# file_size_checker(stepname, filename, minsize, maxsize) - negative means ignore -# file_size_checker('create db','testing.db',100,-1) - -num_records=rand(5) # 0000 -record_step("add #{num_records}","start","n/a") -status=false -(0..num_records).each do |i| - randstring="abc"; - # "a;lskdfja;sdfj;alsdfj;aslfdj;alsfja;lsfdj;alsfja;lsjfd;lasfjl;asdfja;slfj;alsjf;asljf;alsjf;lasdjf;lasjf;lasjf;alsjf;lashflkashflkerhflkdsvnlasldhlfaldf" - # status=system "sqlite3 testing.db \"insert into blah (name) values ('#{randstring}');\"" - system "megatest -step testing :state wrote_junk :status #{num_records}" - sleep(5) - puts "i=#{i}" -end -if status==0 - status='pass' -else - status='fail' -end - -record_step("add #{num_records}","end",status) - - - - DELETED tests/fullrun/tests/sqlitespeed/testconfig Index: tests/fullrun/tests/sqlitespeed/testconfig ================================================================== --- tests/fullrun/tests/sqlitespeed/testconfig +++ /dev/null @@ -1,13 +0,0 @@ -[setup] -runscript runscript.rb -tags non important,dumb junk - -[requirements] -waiton runfirst - -[items] -MANYITEMS [system (env > envfile.txt;echo aa ab ac ad ae af ag ah ai)] -# BORKED - -[test_meta] -jobgroup sqlite3 DELETED tests/fullrun/tests/test_mt_vars/altvarnotset.logpro Index: tests/fullrun/tests/test_mt_vars/altvarnotset.logpro ================================================================== --- tests/fullrun/tests/test_mt_vars/altvarnotset.logpro +++ /dev/null @@ -1,1 +0,0 @@ -(expect:error in "LogFileBody" = 0 "a file that should never exist" #/what a dumb filename this is/) DELETED tests/fullrun/tests/test_mt_vars/altvarnotset.sh Index: tests/fullrun/tests/test_mt_vars/altvarnotset.sh ================================================================== --- tests/fullrun/tests/test_mt_vars/altvarnotset.sh +++ /dev/null @@ -1,3 +0,0 @@ -#!/usr/bin/env bash - -! grep ALT_VAR megatest.sh DELETED tests/fullrun/tests/test_mt_vars/bogousnotset.logpro Index: tests/fullrun/tests/test_mt_vars/bogousnotset.logpro ================================================================== --- tests/fullrun/tests/test_mt_vars/bogousnotset.logpro +++ /dev/null @@ -1,1 +0,0 @@ -(expect:error in "LogFileBody" = 0 "a file that should never exist" #/what a dumb filename this is/) DELETED tests/fullrun/tests/test_mt_vars/bogousnotset.sh Index: tests/fullrun/tests/test_mt_vars/bogousnotset.sh ================================================================== --- tests/fullrun/tests/test_mt_vars/bogousnotset.sh +++ /dev/null @@ -1,3 +0,0 @@ -#!/usr/bin/env bash - -! grep BOGOUS megatest.sh DELETED tests/fullrun/tests/test_mt_vars/currentisblah.logpro Index: tests/fullrun/tests/test_mt_vars/currentisblah.logpro ================================================================== --- tests/fullrun/tests/test_mt_vars/currentisblah.logpro +++ /dev/null @@ -1,1 +0,0 @@ -(expect:error in "LogFileBody" = 0 "a file that should never exist" #/what a dumb filename this is/) DELETED tests/fullrun/tests/test_mt_vars/currentisblah.sh Index: tests/fullrun/tests/test_mt_vars/currentisblah.sh ================================================================== --- tests/fullrun/tests/test_mt_vars/currentisblah.sh +++ /dev/null @@ -1,3 +0,0 @@ -#!/usr/bin/env bash - -grep -e '^export CURRENT' megatest.sh | grep /tmp/nada DELETED tests/fullrun/tests/test_mt_vars/empty_var.logpro Index: tests/fullrun/tests/test_mt_vars/empty_var.logpro ================================================================== --- tests/fullrun/tests/test_mt_vars/empty_var.logpro +++ /dev/null @@ -1,1 +0,0 @@ -(expect:error in "LogFileBody" = 0 "a file that should never exist" #/what a dumb filename this is/) DELETED tests/fullrun/tests/test_mt_vars/empty_var.sh Index: tests/fullrun/tests/test_mt_vars/empty_var.sh ================================================================== --- tests/fullrun/tests/test_mt_vars/empty_var.sh +++ /dev/null @@ -1,6 +0,0 @@ -#!/usr/bin/env bash - -if [ x$EMPTY_VAR != "x" ];then - echo BAD EMPTY VAR! - exit 1 -fi DELETED tests/fullrun/tests/test_mt_vars/eval_vars.sh Index: tests/fullrun/tests/test_mt_vars/eval_vars.sh ================================================================== --- tests/fullrun/tests/test_mt_vars/eval_vars.sh +++ /dev/null @@ -1,7 +0,0 @@ -#!/bin/bash - -if env | grep VARWITHDOLLARSIGNS | grep USER;then - exit 1 # fails! -else - exit 0 # good! -fi DELETED tests/fullrun/tests/test_mt_vars/lookithome.logpro Index: tests/fullrun/tests/test_mt_vars/lookithome.logpro ================================================================== --- tests/fullrun/tests/test_mt_vars/lookithome.logpro +++ /dev/null @@ -1,1 +0,0 @@ -(expect:error in "LogFileBody" = 0 "a file that should never exist" #/what a dumb filename this is/) DELETED tests/fullrun/tests/test_mt_vars/lookittmp.logpro Index: tests/fullrun/tests/test_mt_vars/lookittmp.logpro ================================================================== --- tests/fullrun/tests/test_mt_vars/lookittmp.logpro +++ /dev/null @@ -1,1 +0,0 @@ -(expect:error in "LogFileBody" = 0 "a file that should never exist" #/what a dumb filename this is/) DELETED tests/fullrun/tests/test_mt_vars/test-path-file.sh Index: tests/fullrun/tests/test_mt_vars/test-path-file.sh ================================================================== --- tests/fullrun/tests/test_mt_vars/test-path-file.sh +++ /dev/null @@ -1,28 +0,0 @@ -#!/bin/bash - - -# get a previous test -export EZFAILPATH=`$MT_MEGATEST -test-files envfile.txt -target $MT_TARGET :runname $MT_RUNNAME -testpatt runfirst/a%` - -echo "Found |$EZFAILPATH|" - -if [ -e $EZFAILPATH ];then - echo All good! -else - echo NOT good! - exit 1 -fi - -export EZFAILPATH2=`$MT_MEGATEST -test-paths -target $MT_TARGET :runname $MT_RUNNAME -testpatt runfirst/a%` - -echo "Found |$EZFAILPATH2|" - -if [ -e $EZFAILPATH2 ];then - echo All good! -else - echo NOT good! - exit 1 -fi - - -exit 0 DELETED tests/fullrun/tests/test_mt_vars/test-path.logpro Index: tests/fullrun/tests/test_mt_vars/test-path.logpro ================================================================== --- tests/fullrun/tests/test_mt_vars/test-path.logpro +++ /dev/null @@ -1,1 +0,0 @@ -(expect:error in "LogFileBody" = 0 "a file that should never exist" #/what a dumb filename this is/) DELETED tests/fullrun/tests/test_mt_vars/testconfig Index: tests/fullrun/tests/test_mt_vars/testconfig ================================================================== --- tests/fullrun/tests/test_mt_vars/testconfig +++ /dev/null @@ -1,58 +0,0 @@ -[setup] - -[ezsteps] -lookittmp ls /tmp -lookithome ls /home -# $CURRENT should be /tmp/nada -currentisblah currentisblah.sh - -# $BOGOUS should NOT be set -bogousnotset bogousnotset.sh - -# ALT_VAR should NOT be set -altvarnotset altvarnotset.sh - -# EMPTY_VAR should be an empty string -empty_var empty_var.sh - -# VACKYVAR should be set to a path -vackyvar vackyvar.sh - -# test-path and test-file -test-path test-path-file.sh - -# verify that vars with $ signs get expanded -varwithdollar eval_vars.sh - -emptyvars bash -c 'if [[ $VARNOVAL == "" ]];then echo HAVE_VARNOVAL;else echo "ERROR: VARNOVAL not found";fi' -emptyvar_withspace bash -c 'if [[ $VARNOVAL_WITHSPACE == "" ]];then echo HAVE_VARNOVAL_WITHSPACE;else echo "ERROR: VARNOVAL_WITHSPACE not found";fi' -emptyvar_megatest.sh egrep VARNO megatest.sh - -[requirements] -waiton runfirst -priority 0 - -[items] -NUMNUM [system cat $MT_RUN_AREA_HOME/tmp/$USER/$sysname/$fsname/$datapath/$MT_RUNNAME/$PREDICTABLE] - -[logpro] -emptyvars ;; - (expect:error in "LogFileBody" = 0 "VARNOVAL not found" #/ERROR: VARNOVAL not found/) - (expect:required in "LogFileBody" = 1 "HAVE_VARNOVAL" #/HAVE_VARNOVAL/) - -emptyvar_withspace ;; - (expect:error in "LogFileBody" = 0 "VARNOVAL_WITHSPACE not found" #/ERROR: VARNOVAL_WITHSPACE not found/) - (expect:required in "LogFileBody" = 1 "HAVE_VARNOVAL_WITHSPACE" #/HAVE_VARNOVAL_WITHSPACE/) - -emptyvar_megatest.sh ;; - (expect:error in "LogFileBody" = 0 "No errors expected" #/ERR/i) - (expect:required in "LogFileBody" = 1 "VARNOVAL_WITHSPACE" #/VARNOVAL_WITHSPACE/) - (expect:required in "LogFileBody" = 1 "VARNOVAL" #/VARNOVAL/) - -[test_meta] -author matt -owner bob -description This test runs a single ezstep which is expected to pass, no logpro file. - -tags first,single -reviewed 09/10/2011, by Matt DELETED tests/fullrun/tests/test_mt_vars/vackyvar.logpro Index: tests/fullrun/tests/test_mt_vars/vackyvar.logpro ================================================================== --- tests/fullrun/tests/test_mt_vars/vackyvar.logpro +++ /dev/null @@ -1,1 +0,0 @@ -(expect:error in "LogFileBody" = 0 "a file that should never exist" #/what a dumb filename this is/) DELETED tests/fullrun/tests/test_mt_vars/vackyvar.sh Index: tests/fullrun/tests/test_mt_vars/vackyvar.sh ================================================================== --- tests/fullrun/tests/test_mt_vars/vackyvar.sh +++ /dev/null @@ -1,3 +0,0 @@ -#!/usr/bin/env bash - -grep VACKYVAR megatest.sh | grep fullrun DELETED tests/fullrun/tests/test_mt_vars/varwithdollar.logpro Index: tests/fullrun/tests/test_mt_vars/varwithdollar.logpro ================================================================== --- tests/fullrun/tests/test_mt_vars/varwithdollar.logpro +++ /dev/null @@ -1,1 +0,0 @@ -(expect:error in "LogFileBody" = 0 "a file that should never exist" #/what a dumb filename this is/) DELETED tests/fullrun/tests/testxz/testconfig Index: tests/fullrun/tests/testxz/testconfig ================================================================== --- tests/fullrun/tests/testxz/testconfig +++ /dev/null @@ -1,15 +0,0 @@ -# Add additional steps here. Format is "stepname script" -[ezsteps] -listfiles ls - -# Test requirements are specified here -[requirements] -waiton blocktestxz - -# test_meta is a section for storing additional data on your test -[test_meta] -author mrwellan -owner mrwellan -description This test should never get run due to blocktestxz failing -tags tagone,tagtwo -reviewed never DELETED tests/fullrun/tests/wait_no_items1/testconfig Index: tests/fullrun/tests/wait_no_items1/testconfig ================================================================== --- tests/fullrun/tests/wait_no_items1/testconfig +++ /dev/null @@ -1,17 +0,0 @@ -[ezsteps] -listfiles ls - -[requirements] -waiton no_items - -[items] - -[test_meta] -author matt -owner bob -description This test runs a single ezstep which is expected to pass \ -but there is an items definition with no items. This should evoke an \ -error. - -tags first,single -reviewed 09/10/2011, by Matt DELETED tests/fullrun/tests/wait_no_items2/testconfig Index: tests/fullrun/tests/wait_no_items2/testconfig ================================================================== --- tests/fullrun/tests/wait_no_items2/testconfig +++ /dev/null @@ -1,17 +0,0 @@ -[ezsteps] -listfiles ls - -[requirements] -waiton wait_no_items1 - -[items] - -[test_meta] -author matt -owner bob -description This test runs a single ezstep which is expected to pass \ -but there is an items definition with no items. This should evoke an \ -error. - -tags first,single -reviewed 09/10/2011, by Matt DELETED tests/fullrun/tests/wait_no_items3/testconfig Index: tests/fullrun/tests/wait_no_items3/testconfig ================================================================== --- tests/fullrun/tests/wait_no_items3/testconfig +++ /dev/null @@ -1,17 +0,0 @@ -[ezsteps] -listfiles ls - -[requirements] -waiton wait_no_items2 - -[items] - -[test_meta] -author matt -owner bob -description This test runs a single ezstep which is expected to pass \ -but there is an items definition with no items. This should evoke an \ -error. - -tags first,single -reviewed 09/10/2011, by Matt DELETED tests/fullrun/tests/wait_no_items4/testconfig Index: tests/fullrun/tests/wait_no_items4/testconfig ================================================================== --- tests/fullrun/tests/wait_no_items4/testconfig +++ /dev/null @@ -1,17 +0,0 @@ -[ezsteps] -listfiles ls - -[requirements] -waiton wait_no_items3 - -[items] - -[test_meta] -author matt -owner bob -description This test runs a single ezstep which is expected to pass \ -but there is an items definition with no items. This should evoke an \ -error. - -tags first,single -reviewed 09/10/2011, by Matt DELETED tests/installall/config/megatest.config.dat Index: tests/installall/config/megatest.config.dat ================================================================== --- tests/installall/config/megatest.config.dat +++ /dev/null @@ -1,1 +0,0 @@ -../megatest.config DELETED tests/installall/config/runconfigs.config.dat Index: tests/installall/config/runconfigs.config.dat ================================================================== --- tests/installall/config/runconfigs.config.dat +++ /dev/null @@ -1,1 +0,0 @@ -../runconfigs.config DELETED tests/installall/config/sheet-names.cfg Index: tests/installall/config/sheet-names.cfg ================================================================== --- tests/installall/config/sheet-names.cfg +++ /dev/null @@ -1,2 +0,0 @@ -megatest.config -runconfigs.config DELETED tests/installall/config/sxml/_sheets.sxml Index: tests/installall/config/sxml/_sheets.sxml ================================================================== --- tests/installall/config/sxml/_sheets.sxml +++ /dev/null @@ -1,51 +0,0 @@ -((@ (http://www.w3.org/2001/XMLSchema-instance:schemaLocation - "http://www.gnumeric.org/v9.xsd")) - (http://www.gnumeric.org/v10.dtd:Version - (@ (Minor "17") (Major "10") (Full "1.10.17") (Epoch "1"))) - (http://www.gnumeric.org/v10.dtd:Attributes - (http://www.gnumeric.org/v10.dtd:Attribute - (http://www.gnumeric.org/v10.dtd:type "4") - (http://www.gnumeric.org/v10.dtd:name - "WorkbookView::show_horizontal_scrollbar") - (http://www.gnumeric.org/v10.dtd:value "TRUE")) - (http://www.gnumeric.org/v10.dtd:Attribute - (http://www.gnumeric.org/v10.dtd:type "4") - (http://www.gnumeric.org/v10.dtd:name - "WorkbookView::show_vertical_scrollbar") - (http://www.gnumeric.org/v10.dtd:value "TRUE")) - (http://www.gnumeric.org/v10.dtd:Attribute - (http://www.gnumeric.org/v10.dtd:type "4") - (http://www.gnumeric.org/v10.dtd:name "WorkbookView::show_notebook_tabs") - (http://www.gnumeric.org/v10.dtd:value "TRUE")) - (http://www.gnumeric.org/v10.dtd:Attribute - (http://www.gnumeric.org/v10.dtd:type "4") - (http://www.gnumeric.org/v10.dtd:name "WorkbookView::do_auto_completion") - (http://www.gnumeric.org/v10.dtd:value "TRUE")) - (http://www.gnumeric.org/v10.dtd:Attribute - (http://www.gnumeric.org/v10.dtd:type "4") - (http://www.gnumeric.org/v10.dtd:name "WorkbookView::is_protected") - (http://www.gnumeric.org/v10.dtd:value "FALSE"))) - (urn:oasis:names:tc:opendocument:xmlns:office:1.0:document-meta - (@ (urn:oasis:names:tc:opendocument:xmlns:office:1.0:version "1.2")) - (urn:oasis:names:tc:opendocument:xmlns:office:1.0:meta - (http://purl.org/dc/elements/1.1/:date "2013-07-21T23:45:07Z") - (urn:oasis:names:tc:opendocument:xmlns:meta:1.0:creation-date - "2013-07-21T23:42:35Z"))) - (http://www.gnumeric.org/v10.dtd:Calculation - (@ (MaxIterations "100") - (ManualRecalc "0") - (IterationTolerance "0.001") - (FloatRadix "2") - (FloatDigits "53") - (EnableIteration "1"))) - (http://www.gnumeric.org/v10.dtd:SheetNameIndex - (http://www.gnumeric.org/v10.dtd:SheetName - (@ (http://www.gnumeric.org/v10.dtd:Rows "65536") - (http://www.gnumeric.org/v10.dtd:Cols "256")) - "megatest.config") - (http://www.gnumeric.org/v10.dtd:SheetName - (@ (http://www.gnumeric.org/v10.dtd:Rows "65536") - (http://www.gnumeric.org/v10.dtd:Cols "256")) - "runconfigs.config")) - (http://www.gnumeric.org/v10.dtd:Geometry (@ (Width "1440") (Height "647"))) - (http://www.gnumeric.org/v10.dtd:UIData (@ (SelectedTab "0")))) DELETED tests/installall/config/sxml/_workbook.sxml Index: tests/installall/config/sxml/_workbook.sxml ================================================================== --- tests/installall/config/sxml/_workbook.sxml +++ /dev/null @@ -1,1 +0,0 @@ -(*TOP* (*PI* xml "version=\"1.0\" encoding=\"UTF-8\"")) DELETED tests/installall/config/sxml/megatest.config.sxml Index: tests/installall/config/sxml/megatest.config.sxml ================================================================== --- tests/installall/config/sxml/megatest.config.sxml +++ /dev/null @@ -1,108 +0,0 @@ -(http://www.gnumeric.org/v10.dtd:Sheet - (@ (Visibility "GNM_SHEET_VISIBILITY_VISIBLE") - (OutlineSymbolsRight "1") - (OutlineSymbolsBelow "1") - (HideZero "0") - (HideRowHeader "0") - (HideGrid "0") - (HideColHeader "0") - (GridColor "0:0:0") - (DisplayOutlines "1") - (DisplayFormulas "0")) - (http://www.gnumeric.org/v10.dtd:MaxCol "5") - (http://www.gnumeric.org/v10.dtd:MaxRow "7") - (http://www.gnumeric.org/v10.dtd:Zoom "1") - (http://www.gnumeric.org/v10.dtd:Names - (http://www.gnumeric.org/v10.dtd:Name - (http://www.gnumeric.org/v10.dtd:name "Print_Area") - (http://www.gnumeric.org/v10.dtd:value "#REF!") - (http://www.gnumeric.org/v10.dtd:position "A1")) - (http://www.gnumeric.org/v10.dtd:Name - (http://www.gnumeric.org/v10.dtd:name "Sheet_Title") - (http://www.gnumeric.org/v10.dtd:value "\"megatest.config\"") - (http://www.gnumeric.org/v10.dtd:position "A1"))) - (http://www.gnumeric.org/v10.dtd:PrintInformation - (http://www.gnumeric.org/v10.dtd:Margins - (http://www.gnumeric.org/v10.dtd:top (@ (PrefUnit "mm") (Points "120"))) - (http://www.gnumeric.org/v10.dtd:bottom - (@ (PrefUnit "mm") (Points "120"))) - (http://www.gnumeric.org/v10.dtd:left (@ (PrefUnit "mm") (Points "72"))) - (http://www.gnumeric.org/v10.dtd:right (@ (PrefUnit "mm") (Points "72"))) - (http://www.gnumeric.org/v10.dtd:header - (@ (PrefUnit "mm") (Points "72"))) - (http://www.gnumeric.org/v10.dtd:footer - (@ (PrefUnit "mm") (Points "72")))) - (http://www.gnumeric.org/v10.dtd:Scale - (@ (type "percentage") (percentage "100"))) - (http://www.gnumeric.org/v10.dtd:vcenter (@ (value "0"))) - (http://www.gnumeric.org/v10.dtd:hcenter (@ (value "0"))) - (http://www.gnumeric.org/v10.dtd:grid (@ (value "0"))) - (http://www.gnumeric.org/v10.dtd:even_if_only_styles (@ (value "0"))) - (http://www.gnumeric.org/v10.dtd:monochrome (@ (value "0"))) - (http://www.gnumeric.org/v10.dtd:draft (@ (value "0"))) - (http://www.gnumeric.org/v10.dtd:titles (@ (value "0"))) - (http://www.gnumeric.org/v10.dtd:do_not_print (@ (value "0"))) - (http://www.gnumeric.org/v10.dtd:print_range (@ (value "0"))) - (http://www.gnumeric.org/v10.dtd:order "d_then_r") - (http://www.gnumeric.org/v10.dtd:orientation "portrait") - (http://www.gnumeric.org/v10.dtd:Header - (@ (Right "") (Middle "&[TAB]") (Left ""))) - (http://www.gnumeric.org/v10.dtd:Footer - (@ (Right "") (Middle "Page &[PAGE]") (Left ""))) - (http://www.gnumeric.org/v10.dtd:paper "na_letter") - (http://www.gnumeric.org/v10.dtd:comments "in_place") - (http://www.gnumeric.org/v10.dtd:errors "as_displayed")) - (http://www.gnumeric.org/v10.dtd:Styles - (http://www.gnumeric.org/v10.dtd:StyleRegion - (@ (startRow "0") (startCol "0") (endRow "65535") (endCol "255")) - (http://www.gnumeric.org/v10.dtd:Style - (@ (WrapText "0") - (VAlign "2") - (ShrinkToFit "0") - (Shade "0") - (Rotation "0") - (PatternColor "0:0:0") - (Locked "1") - (Indent "0") - (Hidden "0") - (HAlign "1") - (Format "General") - (Fore "0:0:0") - (Back "FFFF:FFFF:FFFF")) - (http://www.gnumeric.org/v10.dtd:Font - (@ (Unit "10") - (Underline "0") - (StrikeThrough "0") - (Script "0") - (Italic "0") - (Bold "0")) - "Sans")))) - (http://www.gnumeric.org/v10.dtd:Cols - (@ (DefaultSizePts "48")) - (http://www.gnumeric.org/v10.dtd:ColInfo - (@ (Unit "112.5") (No "0") (HardSize "1"))) - (http://www.gnumeric.org/v10.dtd:ColInfo (@ (Unit "48") (No "1"))) - (http://www.gnumeric.org/v10.dtd:ColInfo - (@ (Unit "63.75") (No "2") (HardSize "1"))) - (http://www.gnumeric.org/v10.dtd:ColInfo (@ (Unit "48") (No "3"))) - (http://www.gnumeric.org/v10.dtd:ColInfo - (@ (Unit "86.25") (No "4") (HardSize "1"))) - (http://www.gnumeric.org/v10.dtd:ColInfo (@ (Unit "48") (No "5")))) - (http://www.gnumeric.org/v10.dtd:Rows - (@ (DefaultSizePts "12.75")) - (http://www.gnumeric.org/v10.dtd:RowInfo - (@ (Unit "12.75") (No "0") (Count "8")))) - (http://www.gnumeric.org/v10.dtd:Selections - (@ (CursorRow "0") (CursorCol "0")) - (http://www.gnumeric.org/v10.dtd:Selection - (@ (startRow "0") (startCol "0") (endRow "0") (endCol "0")))) - (http://www.gnumeric.org/v10.dtd:SheetLayout (@ (TopLeft "A1"))) - (http://www.gnumeric.org/v10.dtd:Solver - (@ (ProgramR "0") - (ProblemType "0") - (NonNeg "1") - (ModelType "0") - (MaxTime "60") - (MaxIter "1000") - (Discr "0") - (AutoScale "0")))) DELETED tests/installall/config/sxml/runconfigs.config.sxml Index: tests/installall/config/sxml/runconfigs.config.sxml ================================================================== --- tests/installall/config/sxml/runconfigs.config.sxml +++ /dev/null @@ -1,111 +0,0 @@ -(http://www.gnumeric.org/v10.dtd:Sheet - (@ (Visibility "GNM_SHEET_VISIBILITY_VISIBLE") - (OutlineSymbolsRight "1") - (OutlineSymbolsBelow "1") - (HideZero "0") - (HideRowHeader "0") - (HideGrid "0") - (HideColHeader "0") - (GridColor "0:0:0") - (DisplayOutlines "1") - (DisplayFormulas "0")) - (http://www.gnumeric.org/v10.dtd:MaxCol "3") - (http://www.gnumeric.org/v10.dtd:MaxRow "7") - (http://www.gnumeric.org/v10.dtd:Zoom "1") - (http://www.gnumeric.org/v10.dtd:Names - (http://www.gnumeric.org/v10.dtd:Name - (http://www.gnumeric.org/v10.dtd:name "Print_Area") - (http://www.gnumeric.org/v10.dtd:value "#REF!") - (http://www.gnumeric.org/v10.dtd:position "A1")) - (http://www.gnumeric.org/v10.dtd:Name - (http://www.gnumeric.org/v10.dtd:name "Sheet_Title") - (http://www.gnumeric.org/v10.dtd:value "\"runconfigs.config\"") - (http://www.gnumeric.org/v10.dtd:position "A1"))) - (http://www.gnumeric.org/v10.dtd:PrintInformation - (http://www.gnumeric.org/v10.dtd:Margins - (http://www.gnumeric.org/v10.dtd:top (@ (PrefUnit "mm") (Points "120"))) - (http://www.gnumeric.org/v10.dtd:bottom - (@ (PrefUnit "mm") (Points "120"))) - (http://www.gnumeric.org/v10.dtd:left (@ (PrefUnit "mm") (Points "72"))) - (http://www.gnumeric.org/v10.dtd:right (@ (PrefUnit "mm") (Points "72"))) - (http://www.gnumeric.org/v10.dtd:header - (@ (PrefUnit "mm") (Points "72"))) - (http://www.gnumeric.org/v10.dtd:footer - (@ (PrefUnit "mm") (Points "72")))) - (http://www.gnumeric.org/v10.dtd:Scale - (@ (type "percentage") (percentage "100"))) - (http://www.gnumeric.org/v10.dtd:vcenter (@ (value "0"))) - (http://www.gnumeric.org/v10.dtd:hcenter (@ (value "0"))) - (http://www.gnumeric.org/v10.dtd:grid (@ (value "0"))) - (http://www.gnumeric.org/v10.dtd:even_if_only_styles (@ (value "0"))) - (http://www.gnumeric.org/v10.dtd:monochrome (@ (value "0"))) - (http://www.gnumeric.org/v10.dtd:draft (@ (value "0"))) - (http://www.gnumeric.org/v10.dtd:titles (@ (value "0"))) - (http://www.gnumeric.org/v10.dtd:do_not_print (@ (value "0"))) - (http://www.gnumeric.org/v10.dtd:print_range (@ (value "0"))) - (http://www.gnumeric.org/v10.dtd:order "d_then_r") - (http://www.gnumeric.org/v10.dtd:orientation "portrait") - (http://www.gnumeric.org/v10.dtd:Header - (@ (Right "") (Middle "&[TAB]") (Left ""))) - (http://www.gnumeric.org/v10.dtd:Footer - (@ (Right "") (Middle "Page &[PAGE]") (Left ""))) - (http://www.gnumeric.org/v10.dtd:paper "na_letter") - (http://www.gnumeric.org/v10.dtd:comments "in_place") - (http://www.gnumeric.org/v10.dtd:errors "as_displayed")) - (http://www.gnumeric.org/v10.dtd:Styles - (http://www.gnumeric.org/v10.dtd:StyleRegion - (@ (startRow "0") (startCol "0") (endRow "65535") (endCol "255")) - (http://www.gnumeric.org/v10.dtd:Style - (@ (WrapText "0") - (VAlign "2") - (ShrinkToFit "0") - (Shade "0") - (Rotation "0") - (PatternColor "0:0:0") - (Locked "1") - (Indent "0") - (Hidden "0") - (HAlign "1") - (Format "General") - (Fore "0:0:0") - (Back "FFFF:FFFF:FFFF")) - (http://www.gnumeric.org/v10.dtd:Font - (@ (Unit "10") - (Underline "0") - (StrikeThrough "0") - (Script "0") - (Italic "0") - (Bold "0")) - "Sans")))) - (http://www.gnumeric.org/v10.dtd:Cols - (@ (DefaultSizePts "48")) - (http://www.gnumeric.org/v10.dtd:ColInfo - (@ (Unit "108.8") (No "0") (HardSize "1"))) - (http://www.gnumeric.org/v10.dtd:ColInfo - (@ (Unit "97.5") (No "1") (HardSize "1"))) - (http://www.gnumeric.org/v10.dtd:ColInfo - (@ (Unit "100.5") (No "2") (HardSize "1") (Count "2")))) - (http://www.gnumeric.org/v10.dtd:Rows - (@ (DefaultSizePts "12.75")) - (http://www.gnumeric.org/v10.dtd:RowInfo - (@ (Unit "13.5") (No "0") (Count "2"))) - (http://www.gnumeric.org/v10.dtd:RowInfo (@ (Unit "12.75") (No "2"))) - (http://www.gnumeric.org/v10.dtd:RowInfo - (@ (Unit "13.5") (No "3") (Count "2"))) - (http://www.gnumeric.org/v10.dtd:RowInfo (@ (Unit "12.75") (No "5"))) - (http://www.gnumeric.org/v10.dtd:RowInfo (@ (Unit "13.5") (No "6"))) - (http://www.gnumeric.org/v10.dtd:RowInfo (@ (Unit "12.75") (No "7")))) - (http://www.gnumeric.org/v10.dtd:Selections - (@ (CursorRow "7") (CursorCol "3")) - (http://www.gnumeric.org/v10.dtd:Selection - (@ (startRow "7") (startCol "3") (endRow "7") (endCol "3")))) - (http://www.gnumeric.org/v10.dtd:SheetLayout (@ (TopLeft "A1"))) - (http://www.gnumeric.org/v10.dtd:Solver - (@ (ProgramR "0") - (ProblemType "0") - (NonNeg "1") - (ModelType "0") - (MaxTime "60") - (MaxIter "1000") - (Discr "0") - (AutoScale "0")))) DELETED tests/installall/configs/chicken-4.8.0.4.config Index: tests/installall/configs/chicken-4.8.0.4.config ================================================================== --- tests/installall/configs/chicken-4.8.0.4.config +++ /dev/null @@ -1,1 +0,0 @@ -CHICKEN_URL http://code.call-cc.org/releases/4.8.0/chicken-4.8.0.4.tar.gz DELETED tests/installall/configs/chicken-4.8.1.config Index: tests/installall/configs/chicken-4.8.1.config ================================================================== --- tests/installall/configs/chicken-4.8.1.config +++ /dev/null @@ -1,1 +0,0 @@ -CHICKEN_URL http://code.call-cc.org/dev-snapshots/2013/01/04/chicken-4.8.1.tar.gz DELETED tests/installall/megatest.config Index: tests/installall/megatest.config ================================================================== --- tests/installall/megatest.config +++ /dev/null @@ -1,24 +0,0 @@ -[fields] -CHICKEN_VERSION TEXT -MEGATEST_VERSION TEXT -IUPMODE TEXT -BUILD_TAG TEXT - -[setup] -max_concurrent_jobs 6 -linktree #{getenv MT_RUN_AREA_HOME}/links -testcopycmd cp --remove-destination -rsv TEST_SRC_PATH/. TEST_TARG_PATH/. >> TEST_TARG_PATH/mt_launch.log 2>> TEST_TARG_PATH/mt_launch.log - -[jobtools] -useshell yes -launcher nbfind - -[env-override] -EXAMPLE_VAR example value - -[server] -port 9080 - -[disks] -disk0 #{getenv MT_RUN_AREA_HOME}/runs - DELETED tests/installall/runconfigs.config Index: tests/installall/runconfigs.config ================================================================== --- tests/installall/runconfigs.config +++ /dev/null @@ -1,38 +0,0 @@ -[.............] -# -# [CHICKEN_VERSION/MEGATEST_VERSION/IUPMODE/PLATFORM/BUILD_TAG] -# - -[default] -ALLTESTS see this variable -PREFIX #{getenv MT_RUN_AREA_HOME}/#{getenv BUILD_TAG}/#{getenv MT_RUNNAME} -DOWNLOADS #{getenv MT_RUN_AREA_HOME}/downloads -IUPLIB 26g4 -PLATFORM linux -LOGPRO_VERSION v1.05 -BUILDSQLITE yes -SQLITE3_VERSION 3071401 -ZEROMQ_VERSION 2.2.0 -logpro_VERSION v1.08 -stml_VERSION v0.901 -megatest_VERSION v1.5511 - -[include configs/hicken-#{getenv CHICKEN_VERSION}.config] - -# Currently must have at least one variable in a section -[4.8.0/trunk/bin/std] -IUP_VERSION na - -[4.8.0.4/trunk/src/std] -CHICKEN_URL http://code.call-cc.org/releases/4.8.0/chicken-4.8.0.4.tar.gz -IUP_VERSION na - -[4.8.1/trunk/src/std] -IUP_VERSION na - -[4.8.0/v1.5508/opt] -IUP_VERSION na -PREFIX /opt/chicken/4.8.0 - -[4.8.0/trunk/centos5.7vm] -BUILDSQLITE no DELETED tests/installall/tests/canvas-draw/install.logpro Index: tests/installall/tests/canvas-draw/install.logpro ================================================================== --- tests/installall/tests/canvas-draw/install.logpro +++ /dev/null @@ -1,8 +0,0 @@ -;; You should have at least one expect:required. This ensures that your process ran -(expect:required in "LogFileBody" > 0 "Put description here" #/put pattern here/) - -;; You may need ignores to suppress false error or warning hits from the later expects -;; NOTE: Order is important here! -(expect:ignore in "LogFileBody" < 99 "Ignore the word error in comments" #/^\/\/.*error/) -(expect:warning in "LogFileBody" = 0 "Any warning" #/warn/) -(expect:error in "LogFileBody" = 0 "Any error" (list #/ERROR/ #/error/i)) ;; but disallow any other errors DELETED tests/installall/tests/canvas-draw/install.sh Index: tests/installall/tests/canvas-draw/install.sh ================================================================== --- tests/installall/tests/canvas-draw/install.sh +++ /dev/null @@ -1,5 +0,0 @@ -#!/usr/bin/env bash - -# Run your step here - -source $PREFIX/buildsetup.sh DELETED tests/installall/tests/canvas-draw/testconfig Index: tests/installall/tests/canvas-draw/testconfig ================================================================== --- tests/installall/tests/canvas-draw/testconfig +++ /dev/null @@ -1,18 +0,0 @@ -# Add additional steps here. Format is "stepname script" -[ezsteps] -install install.sh - -# Test requirements are specified here -[requirements] -waiton iuplib setup - -# Iteration for your tests are controlled by the items section -[items] - -# test_meta is a section for storing additional data on your test -[test_meta] -author matt -owner matt -description Install the canvas-draw egg -tags tagone,tagtwo -reviewed never DELETED tests/installall/tests/chicken/compile.logpro Index: tests/installall/tests/chicken/compile.logpro ================================================================== --- tests/installall/tests/chicken/compile.logpro +++ /dev/null @@ -1,10 +0,0 @@ -;; You should have at least one expect:required. This ensures that your process ran -(expect:required in "LogFileBody" > 0 "Leaving directory ..." #/Leaving directory/) - -;; You may need ignores to suppress false error or warning hits from the later expects -;; NOTE: Order is important here! -(expect:ignore in "LogFileBody" < 99 "Ignore the word error in comments" #/^\/\/.*error/) -(expect:ignore in "LogFileBody" >= 0 "Ignore HAVE_STRERROR" #/HAVE_STRERROR/) - -(expect:warning in "LogFileBody" = 0 "Any warning" #/warn/) -(expect:error in "LogFileBody" = 0 "Any error" (list #/ERROR/ #/error/i)) ;; but disallow any other errors DELETED tests/installall/tests/chicken/compile.sh Index: tests/installall/tests/chicken/compile.sh ================================================================== --- tests/installall/tests/chicken/compile.sh +++ /dev/null @@ -1,8 +0,0 @@ -#!/usr/bin/env bash - -# Run your step here - -source $PREFIX/buildsetup.sh - -cd chicken-${CHICKEN_VERSION} -make PLATFORM=${PLATFORM} PREFIX=${PREFIX} DELETED tests/installall/tests/chicken/download.logpro Index: tests/installall/tests/chicken/download.logpro ================================================================== --- tests/installall/tests/chicken/download.logpro +++ /dev/null @@ -1,11 +0,0 @@ -;; You should have at least one expect:required. This ensures that your process ran -(expect:required in "LogFileBody" > 0 "README file must be seen" #/README$/) - -;; You may need ignores to suppress false error or warning hits from the later expects -;; NOTE: Order is important here! - -(expect:ignore in "LogFileBody" >= 0 "Ignore error flagged by finalizer-error-test" #/\w+-error/) - -(expect:ignore in "LogFileBody" < 99 "Ignore the word error in comments" #/^\/\/.*error/) -(expect:warning in "LogFileBody" = 0 "Any warning" #/warn/) -(expect:error in "LogFileBody" = 0 "Any error" (list #/ERROR/ #/error/i)) ;; but disallow any other errors DELETED tests/installall/tests/chicken/download.sh Index: tests/installall/tests/chicken/download.sh ================================================================== --- tests/installall/tests/chicken/download.sh +++ /dev/null @@ -1,19 +0,0 @@ -#!/usr/bin/env bash - -# Run your step here - -source $PREFIX/buildsetup.sh - -if [ ! -e ${DOWNLOADS}/chicken-${CHICKEN_VERSION}.tar.gz ]; then - if [ "${CHICKEN_URL}" == "" ]; then - CHICKEN_URL=http://code.call-cc.org/releases/${CHICKEN_VERSION}/chicken-${CHICKEN_VERSION}.tar.gz - fi - echo "Downloading $CHICKEN_URL" - (cd ${DOWNLOADS};wget ${CHICKEN_URL}) -fi - -ls -l ${DOWNLOADS}/chicken-${CHICKEN_VERSION}.tar.gz - -tar xfvz ${DOWNLOADS}/chicken-${CHICKEN_VERSION}.tar.gz - -ls -l chicken-${CHICKEN_VERSION} DELETED tests/installall/tests/chicken/install.logpro Index: tests/installall/tests/chicken/install.logpro ================================================================== --- tests/installall/tests/chicken/install.logpro +++ /dev/null @@ -1,11 +0,0 @@ -;; You should have at least one expect:required. This ensures that your process ran -(expect:required in "LogFileBody" > 0 "Leaving directory" #/Leaving directory/) - -;; You may need ignores to suppress false error or warning hits from the later expects -;; NOTE: Order is important here! - -(expect:ignore in "LogFileBody" >= 0 "Ignore error in some filenames" #/\w+-errors/) - -(expect:ignore in "LogFileBody" < 99 "Ignore the word error in comments" #/^\/\/.*error/) -(expect:warning in "LogFileBody" = 0 "Any warning" #/warn/) -(expect:error in "LogFileBody" = 0 "Any error" (list #/ERROR/ #/error/i)) ;; but disallow any other errors DELETED tests/installall/tests/chicken/install.sh Index: tests/installall/tests/chicken/install.sh ================================================================== --- tests/installall/tests/chicken/install.sh +++ /dev/null @@ -1,11 +0,0 @@ -#!/usr/bin/env bash - -# Run your step here - -source $PREFIX/buildsetup.sh -# source $PREFIX - -cd chicken-${CHICKEN_VERSION} -make PLATFORM=${PLATFORM} PREFIX=${PREFIX} install - -ls -l ${PREFIX}/bin DELETED tests/installall/tests/chicken/testconfig Index: tests/installall/tests/chicken/testconfig ================================================================== --- tests/installall/tests/chicken/testconfig +++ /dev/null @@ -1,22 +0,0 @@ -# Add additional steps here. Format is "stepname script" -[ezsteps] -download download.sh -compile compile.sh -install install.sh - -# Test requirements are specified here -[requirements] -waiton setup -# priority 10 - -# Iteration for your tests are controlled by the items section -[items] -# CHICKEN_VERSION 4.8.0 - -# test_meta is a section for storing additional data on your test -[test_meta] -author matt -owner matt -description Download and install chicken scheme -tags tagone,tagtwo -reviewed never DELETED tests/installall/tests/eggs/install.logpro Index: tests/installall/tests/eggs/install.logpro ================================================================== --- tests/installall/tests/eggs/install.logpro +++ /dev/null @@ -1,9 +0,0 @@ -;; You should have at least one expect:required. This ensures that your process ran -(expect:required in "LogFileBody" > 0 "Last thing done is chmod ..." #/chmod /) - -;; You may need ignores to suppress false error or warning hits from the later expects -;; NOTE: Order is important here! -(expect:ignore in "LogFileBody" >= 0 "Ignore someword-errors" #/\w+-error/) -(expect:ignore in "LogFileBody" < 99 "Ignore the word error in comments" #/^\/\/.*error/) -(expect:warning in "LogFileBody" = 0 "Any warning" #/warn/) -(expect:error in "LogFileBody" = 0 "Any error" (list #/ERROR/ #/error/i)) ;; but disallow any other errors DELETED tests/installall/tests/eggs/install.sh Index: tests/installall/tests/eggs/install.sh ================================================================== --- tests/installall/tests/eggs/install.sh +++ /dev/null @@ -1,8 +0,0 @@ -#!/usr/bin/env bash - -# Run your step here - -source $PREFIX/buildsetup.sh - -$PREFIX/bin/chicken-install $PROX $EGG_NAME - DELETED tests/installall/tests/eggs/testconfig Index: tests/installall/tests/eggs/testconfig ================================================================== --- tests/installall/tests/eggs/testconfig +++ /dev/null @@ -1,20 +0,0 @@ -# Add additional steps here. Format is "stepname script" -[ezsteps] -install install.sh - -# Test requirements are specified here -[requirements] -waiton chicken setup -priority 9 - -# Iteration for your tests are controlled by the items section -[items] -EGG_NAME matchable readline apropos base64 regex-literals format regex-case test coops trace csv dot-locking posix-utils posix-extras directory-utils hostinfo tcp-server rpc csv-xml fmt json md5 ssax sxml-serializer sxml-modifications salmonella sql-de-lite postgresql - -# test_meta is a section for storing additional data on your test -[test_meta] -author matt -owner matt -description Download and install eggs with no significant prerequisites -tags tagone,tagtwo -reviewed never DELETED tests/installall/tests/ffcall/compile.logpro Index: tests/installall/tests/ffcall/compile.logpro ================================================================== --- tests/installall/tests/ffcall/compile.logpro +++ /dev/null @@ -1,8 +0,0 @@ -;; You should have at least one expect:required. This ensures that your process ran -(expect:required in "LogFileBody" > 0 "Leaving directory" #/Leaving directory/) - -;; You may need ignores to suppress false error or warning hits from the later expects -;; NOTE: Order is important here! -(expect:ignore in "LogFileBody" < 99 "Ignore the word error in comments" #/^\/\/.*error/) -(expect:warning in "LogFileBody" = 0 "Any warning" #/warn/) -(expect:error in "LogFileBody" = 0 "Any error" (list #/ERROR/ #/error/i)) ;; but disallow any other errors DELETED tests/installall/tests/ffcall/compile.sh Index: tests/installall/tests/ffcall/compile.sh ================================================================== --- tests/installall/tests/ffcall/compile.sh +++ /dev/null @@ -1,9 +0,0 @@ -#!/usr/bin/env bash - -# Run your step here - -source $PREFIX/buildsetup.sh - -cd ffcall -./configure --prefix=${PREFIX} --enable-shared -make DELETED tests/installall/tests/ffcall/download.logpro Index: tests/installall/tests/ffcall/download.logpro ================================================================== --- tests/installall/tests/ffcall/download.logpro +++ /dev/null @@ -1,8 +0,0 @@ -;; You should have at least one expect:required. This ensures that your process ran -(expect:required in "LogFileBody" > 0 "VERSION" #/ VERSION/) - -;; You may need ignores to suppress false error or warning hits from the later expects -;; NOTE: Order is important here! -(expect:ignore in "LogFileBody" < 99 "Ignore the word error in comments" #/^\/\/.*error/) -(expect:warning in "LogFileBody" = 0 "Any warning" #/warn/) -(expect:error in "LogFileBody" = 0 "Any error" (list #/ERROR/ #/error/i)) ;; but disallow any other errors DELETED tests/installall/tests/ffcall/download.sh Index: tests/installall/tests/ffcall/download.sh ================================================================== --- tests/installall/tests/ffcall/download.sh +++ /dev/null @@ -1,13 +0,0 @@ -#!/usr/bin/env bash - -# Run your step here - -source $PREFIX/buildsetup.sh - -if ! [[ -e ${DOWNLOADS}/ffcall.tar.gz ]] ; then - (cd ${DOWNLOADS};wget http://www.kiatoa.com/matt/iup/ffcall.tar.gz ) -fi - -tar xfvz ${DOWNLOADS}/ffcall.tar.gz - -ls -l ffcall DELETED tests/installall/tests/ffcall/install.logpro Index: tests/installall/tests/ffcall/install.logpro ================================================================== --- tests/installall/tests/ffcall/install.logpro +++ /dev/null @@ -1,8 +0,0 @@ -;; You should have at least one expect:required. This ensures that your process ran -(expect:required in "LogFileBody" > 0 "Leaving directory" #/Leaving directory/) - -;; You may need ignores to suppress false error or warning hits from the later expects -;; NOTE: Order is important here! -(expect:ignore in "LogFileBody" < 99 "Ignore the word error in comments" #/^\/\/.*error/) -(expect:warning in "LogFileBody" = 0 "Any warning" #/warn/) -(expect:error in "LogFileBody" = 0 "Any error" (list #/ERROR/ #/error/i)) ;; but disallow any other errors DELETED tests/installall/tests/ffcall/install.sh Index: tests/installall/tests/ffcall/install.sh ================================================================== --- tests/installall/tests/ffcall/install.sh +++ /dev/null @@ -1,8 +0,0 @@ -#!/usr/bin/env bash - -# Run your step here - -source $PREFIX/buildsetup.sh - -cd ffcall -make install DELETED tests/installall/tests/ffcall/testconfig Index: tests/installall/tests/ffcall/testconfig ================================================================== --- tests/installall/tests/ffcall/testconfig +++ /dev/null @@ -1,20 +0,0 @@ -# Add additional steps here. Format is "stepname script" -[ezsteps] -download download.sh -compile compile.sh -install install.sh - -# Test requirements are specified here -[requirements] -waiton setup - -# Iteration for your tests are controlled by the items section -[items] - -# test_meta is a section for storing additional data on your test -[test_meta] -author matt -owner matt -description Install the ffcall library -tags tagone,tagtwo -reviewed never DELETED tests/installall/tests/iup/install.logpro Index: tests/installall/tests/iup/install.logpro ================================================================== --- tests/installall/tests/iup/install.logpro +++ /dev/null @@ -1,9 +0,0 @@ -;; You should have at least one expect:required. This ensures that your process ran -(expect:required in "LogFileBody" > 0 "chmod is roughly last thing that happens" #/chmod /) - -;; You may need ignores to suppress false error or warning hits from the later expects -;; NOTE: Order is important here! -(expect:ignore in "LogFileBody" >= 0 "Ignore setup-error-handling" #/\w+-error/) -(expect:ignore in "LogFileBody" < 99 "Ignore the word error in comments" #/^\/\/.*error/) -(expect:warning in "LogFileBody" = 0 "Any warning" #/warn/) -(expect:error in "LogFileBody" = 0 "Any error" (list #/ERROR/ #/error/i)) ;; but disallow any other errors DELETED tests/installall/tests/iup/install.sh Index: tests/installall/tests/iup/install.sh ================================================================== --- tests/installall/tests/iup/install.sh +++ /dev/null @@ -1,12 +0,0 @@ -#!/usr/bin/env bash - -# Run your step here -source $PREFIX/buildsetup.sh -# source $PREFIX/setup-chicken4x.sh - -export CSCLIBS=`echo $LD_LIBRARY_PATH | sed 's/:/ -L/g'` -CSC_OPTIONS="-I$PREFIX/include -L$CSCLIBS" $PREFIX/bin/chicken-install $PROX -D no-library-checks -feature disable-iup-web iup -# CSC_OPTIONS="-I$PREFIX/include -L$CSCLIBS" $CHICKEN_INSTALL $PROX -D no-library-checks -feature disable-iup-web -deploy -prefix $DEPLOYTARG iup -# iup:1.0.2 -CSC_OPTIONS="-I$PREFIX/include -L$CSCLIBS" $PREFIX/bin/chicken-install $PROX -D no-library-checks canvas-draw -# CSC_OPTIONS="-I$PREFIX/include -L$CSCLIBS" $CHICKEN_INSTALL $PROX -D no-library-checks -deploy -prefix $DEPLOYTARG canvas-draw DELETED tests/installall/tests/iup/testconfig Index: tests/installall/tests/iup/testconfig ================================================================== --- tests/installall/tests/iup/testconfig +++ /dev/null @@ -1,18 +0,0 @@ -# Add additional steps here. Format is "stepname script" -[ezsteps] -install install.sh - -# Test requirements are specified here -[requirements] -waiton iup#{getenv IUPMODE}lib tougheggs - -# Iteration for your tests are controlled by the items section -[items] - -# test_meta is a section for storing additional data on your test -[test_meta] -author matt -owner matt -description Install iup egg -tags tagone,tagtwo -reviewed never DELETED tests/installall/tests/iupbinlib/compile.logpro Index: tests/installall/tests/iupbinlib/compile.logpro ================================================================== --- tests/installall/tests/iupbinlib/compile.logpro +++ /dev/null @@ -1,8 +0,0 @@ -;; You should have at least one expect:required. This ensures that your process ran -(expect:required in "LogFileBody" > 0 "Put description here" #/put pattern here/) - -;; You may need ignores to suppress false error or warning hits from the later expects -;; NOTE: Order is important here! -(expect:ignore in "LogFileBody" < 99 "Ignore the word error in comments" #/^\/\/.*error/) -(expect:warning in "LogFileBody" = 0 "Any warning" #/warn/) -(expect:error in "LogFileBody" = 0 "Any error" (list #/ERROR/ #/error/i)) ;; but disallow any other errors DELETED tests/installall/tests/iupbinlib/compile.sh Index: tests/installall/tests/iupbinlib/compile.sh ================================================================== --- tests/installall/tests/iupbinlib/compile.sh +++ /dev/null @@ -1,5 +0,0 @@ -#!/usr/bin/env bash - -# Run your step here - -source $PREFIX/buildsetup.sh DELETED tests/installall/tests/iupbinlib/download.logpro Index: tests/installall/tests/iupbinlib/download.logpro ================================================================== --- tests/installall/tests/iupbinlib/download.logpro +++ /dev/null @@ -1,8 +0,0 @@ -;; You should have at least one expect:required. This ensures that your process ran -(expect:required in "LogFileBody" > 0 "README file should show up" #/README/) - -;; You may need ignores to suppress false error or warning hits from the later expects -;; NOTE: Order is important here! -(expect:ignore in "LogFileBody" < 99 "Ignore the word error in comments" #/^\/\/.*error/) -(expect:warning in "LogFileBody" = 0 "Any warning" #/warn/) -(expect:error in "LogFileBody" = 0 "Any error" (list #/ERROR/ #/error/i)) ;; but disallow any other errors DELETED tests/installall/tests/iupbinlib/download.sh Index: tests/installall/tests/iupbinlib/download.sh ================================================================== --- tests/installall/tests/iupbinlib/download.sh +++ /dev/null @@ -1,28 +0,0 @@ -#!/usr/bin/env bash - -# Run your step here -source $PREFIX/buildsetup.sh -# source $PREFIX/setup-chicken4x.sh - -if [[ `uname -a | grep x86_64` == "" ]]; then - export ARCHSIZE='' -else - export ARCHSIZE=64_ -fi - # export files="cd-5.4.1_Linux${IUPLIB}_lib.tar.gz im-3.6.3_Linux${IUPLIB}_lib.tar.gz iup-3.5_Linux${IUPLIB}_lib.tar.gz" -if [[ x$USEOLDIUP == "x" ]];then - export files="cd-5.5.1_Linux${IUPLIB}_${ARCHSIZE}lib.tar.gz im-3.8_Linux${IUPLIB}_${ARCHSIZE}lib.tar.gz iup-3.6_Linux${IUPLIB}_${ARCHSIZE}lib.tar.gz" -else - echo WARNING: Using old IUP libraries - export files="cd-5.4.1_Linux${IUPLIB}_${ARCHSIZE}lib.tar.gz im-3.6.3_Linux${IUPLIB}_${ARCHSIZE}lib.tar.gz iup-3.5_Linux${IUPLIB}_${ARCHSIZE}lib.tar.gz" -fi - -mkdir -p $PREFIX/iuplib -for a in `echo $files` ; do - if ! [[ -e ${DOWNLOADS}/$a ]] ; then - (cd ${DOWNLOADS};wget http://www.kiatoa.com/matt/iup/$a) - fi - echo Untarring $a into $PREFIX/lib - (cd $PREFIX/lib;tar xfvz ${DOWNLOADS}/$a;mv include/* ../include) -done - DELETED tests/installall/tests/iupbinlib/install.logpro Index: tests/installall/tests/iupbinlib/install.logpro ================================================================== --- tests/installall/tests/iupbinlib/install.logpro +++ /dev/null @@ -1,8 +0,0 @@ -;; You should have at least one expect:required. This ensures that your process ran -(expect:required in "LogFileBody" > 0 "Put description here" #/put pattern here/) - -;; You may need ignores to suppress false error or warning hits from the later expects -;; NOTE: Order is important here! -(expect:ignore in "LogFileBody" < 99 "Ignore the word error in comments" #/^\/\/.*error/) -(expect:warning in "LogFileBody" = 0 "Any warning" #/warn/) -(expect:error in "LogFileBody" = 0 "Any error" (list #/ERROR/ #/error/i)) ;; but disallow any other errors DELETED tests/installall/tests/iupbinlib/install.sh Index: tests/installall/tests/iupbinlib/install.sh ================================================================== --- tests/installall/tests/iupbinlib/install.sh +++ /dev/null @@ -1,4 +0,0 @@ -#!/usr/bin/env bash - -# Run your step here -source $PREFIX/buildsetup.sh DELETED tests/installall/tests/iupbinlib/testconfig Index: tests/installall/tests/iupbinlib/testconfig ================================================================== --- tests/installall/tests/iupbinlib/testconfig +++ /dev/null @@ -1,18 +0,0 @@ -# Add additional steps here. Format is "stepname script" -[ezsteps] -download download.sh - -# Test requirements are specified here -[requirements] -waiton ffcall setup - -# Iteration for your tests are controlled by the items section -[items] - -# test_meta is a section for storing additional data on your test -[test_meta] -author matt -owner matt -description Install the iup library if it is not already installed -tags tagone,tagtwo -reviewed never DELETED tests/installall/tests/iupbinlib/untar.logpro Index: tests/installall/tests/iupbinlib/untar.logpro ================================================================== --- tests/installall/tests/iupbinlib/untar.logpro +++ /dev/null @@ -1,8 +0,0 @@ -;; You should have at least one expect:required. This ensures that your process ran -(expect:required in "LogFileBody" > 0 "Put description here" #/put pattern here/) - -;; You may need ignores to suppress false error or warning hits from the later expects -;; NOTE: Order is important here! -(expect:ignore in "LogFileBody" < 99 "Ignore the word error in comments" #/^\/\/.*error/) -(expect:warning in "LogFileBody" = 0 "Any warning" #/warn/) -(expect:error in "LogFileBody" = 0 "Any error" (list #/ERROR/ #/error/i)) ;; but disallow any other errors DELETED tests/installall/tests/iupbinlib/untar.sh Index: tests/installall/tests/iupbinlib/untar.sh ================================================================== --- tests/installall/tests/iupbinlib/untar.sh +++ /dev/null @@ -1,4 +0,0 @@ -#!/usr/bin/env bash - -# Run your step here -source $PREFIX/buildsetup.sh DELETED tests/installall/tests/iupsrclib/cd.logpro Index: tests/installall/tests/iupsrclib/cd.logpro ================================================================== --- tests/installall/tests/iupsrclib/cd.logpro +++ /dev/null @@ -1,3 +0,0 @@ -(expect:ignore in "LogFileBody" >= 0 "Ignore these binary operator errors for now" #/error: missing binary operator/) - -(load "compile.logpro") DELETED tests/installall/tests/iupsrclib/compile.logpro Index: tests/installall/tests/iupsrclib/compile.logpro ================================================================== --- tests/installall/tests/iupsrclib/compile.logpro +++ /dev/null @@ -1,12 +0,0 @@ -;; You should have at least one expect:required. This ensures that your process ran -(expect:required in "LogFileBody" > 0 "Completed signature" #/(Dynamic Library.*Done|Leaving directory|Nothing to be done)/) - -;; You may need ignores to suppress false error or warning hits from the later expects -;; NOTE: Order is important here! -(expect:ignore in "LogFileBody" >= 0 "Ignore files with error in name" #/error.[ch]/) -(expect:ignore in "LogFileBody" >= 0 "Ignore files with errors in name" #/errors.[ch]/) -(expect:ignore in "LogFileBody" >= 0 "Ignore files with warn in name" #/warning.[ch]/) - -(expect:ignore in "LogFileBody" < 99 "Ignore the word error in comments" #/^\/\/.*error/) -(expect:warning in "LogFileBody" = 0 "Any warning" #/warn/) -(expect:error in "LogFileBody" = 0 "Any error" (list #/ERROR/ #/error/i)) ;; but disallow any other errors DELETED tests/installall/tests/iupsrclib/compile.sh Index: tests/installall/tests/iupsrclib/compile.sh ================================================================== --- tests/installall/tests/iupsrclib/compile.sh +++ /dev/null @@ -1,17 +0,0 @@ -#!/usr/bin/env bash - -# Run your step here - -pkg=$1 - -source $PREFIX/buildsetup.sh - -export LUA_SUFFIX= -export LUA_INC=$MT_TEST_RUN_DIR/lua52/include - -if [[ $pkg == "lua52" ]]; then - (cd $pkg/src;make $PLATFORM) -else - (cd $pkg/src;make) -fi - DELETED tests/installall/tests/iupsrclib/download.logpro Index: tests/installall/tests/iupsrclib/download.logpro ================================================================== --- tests/installall/tests/iupsrclib/download.logpro +++ /dev/null @@ -1,13 +0,0 @@ -;; You should have at least one expect:required. This ensures that your process ran -(expect:required in "LogFileBody" > 0 "README file should show up" #/README/) - -;; You may need ignores to suppress false error or warning hits from the later expects -;; NOTE: Order is important here! - -(expect:ignore in "LogFileBody" >= 0 "Ignore files with error in name" #/error.[ch]/) -(expect:ignore in "LogFileBody" >= 0 "Ignore files with errors in name" #/errors.[ch]/) -(expect:ignore in "LogFileBody" >= 0 "Ignore files with warn in name" #/warning.[ch]/) - -(expect:ignore in "LogFileBody" < 99 "Ignore the word error in comments" #/^\/\/.*error/) -(expect:warning in "LogFileBody" = 0 "Any warning" #/warn/) -(expect:error in "LogFileBody" = 0 "Any error" (list #/ERROR/ #/error/i)) ;; but disallow any other errors DELETED tests/installall/tests/iupsrclib/download.sh Index: tests/installall/tests/iupsrclib/download.sh ================================================================== --- tests/installall/tests/iupsrclib/download.sh +++ /dev/null @@ -1,14 +0,0 @@ -#!/usr/bin/env bash - -# Run your step here -source $PREFIX/buildsetup.sh - -mkdir -p $PREFIX/iuplib -for a in cd-5.6.1_Sources.tar.gz im-3.8.1_Sources.tar.gz iup-3.8_Sources.tar.gz lua-5.2.1_Sources.tar.gz; do - if ! [[ -e ${DOWNLOADS}/$a ]] ; then - (cd ${DOWNLOADS};wget http://www.kiatoa.com/matt/iup/$a) - fi - tar xfvz ${DOWNLOADS}/$a -done - -find . -type d -exec chmod ug+x {} \; DELETED tests/installall/tests/iupsrclib/im.logpro Index: tests/installall/tests/iupsrclib/im.logpro ================================================================== --- tests/installall/tests/iupsrclib/im.logpro +++ /dev/null @@ -1,1 +0,0 @@ -(load "compile.logpro") DELETED tests/installall/tests/iupsrclib/install.logpro Index: tests/installall/tests/iupsrclib/install.logpro ================================================================== --- tests/installall/tests/iupsrclib/install.logpro +++ /dev/null @@ -1,8 +0,0 @@ -;; You should have at least one expect:required. This ensures that your process ran -(expect:required in "LogFileBody" > 0 "Put description here" #/put pattern here/) - -;; You may need ignores to suppress false error or warning hits from the later expects -;; NOTE: Order is important here! -(expect:ignore in "LogFileBody" < 99 "Ignore the word error in comments" #/^\/\/.*error/) -(expect:warning in "LogFileBody" = 0 "Any warning" #/warn/) -(expect:error in "LogFileBody" = 0 "Any error" (list #/ERROR/ #/error/i)) ;; but disallow any other errors DELETED tests/installall/tests/iupsrclib/install.sh Index: tests/installall/tests/iupsrclib/install.sh ================================================================== --- tests/installall/tests/iupsrclib/install.sh +++ /dev/null @@ -1,22 +0,0 @@ -#!/usr/bin/env bash - -# Run your step here -source $PREFIX/buildsetup.sh - -# The so files -cp -f im/lib/Linux26g4/*.so $PREFIX/lib -cp -f cd/lib/Linux26g4/*.so $PREFIX/lib -cp -f iup/lib/Linux26g4/*.so $PREFIX/lib - -# The development files -mkdir -p $PREFIX/include/im -cp -fR im/include/*.h $PREFIX/include/im -cp -f im/lib/Linux26g4/*.a $PREFIX/lib - -mkdir -p $PREFIX/include/cd -cp -f cd/include/*.h $PREFIX/include/cd -cp -f cd/lib/Linux26g4/*.a $PREFIX/lib - -mkdir -p /usr/include/iup -cp -f iup/include/*.h $PREFIX/include/iup -cp -f iup/lib/Linux26g4/*.a $PREFIX/lib DELETED tests/installall/tests/iupsrclib/iup.logpro Index: tests/installall/tests/iupsrclib/iup.logpro ================================================================== --- tests/installall/tests/iupsrclib/iup.logpro +++ /dev/null @@ -1,3 +0,0 @@ -(expect:ignore in "LogFileBody" >= 0 "Ignore these binary operator errors for now" #/error: missing binary operator/ expires: "10/10/2013") - -(load "compile.logpro") DELETED tests/installall/tests/iupsrclib/lua.logpro Index: tests/installall/tests/iupsrclib/lua.logpro ================================================================== --- tests/installall/tests/iupsrclib/lua.logpro +++ /dev/null @@ -1,1 +0,0 @@ -(load "compile.logpro") DELETED tests/installall/tests/iupsrclib/testconfig Index: tests/installall/tests/iupsrclib/testconfig ================================================================== --- tests/installall/tests/iupsrclib/testconfig +++ /dev/null @@ -1,22 +0,0 @@ -# Add additional steps here. Format is "stepname script" -[ezsteps] -download download.sh -lua compile.sh lua52 -im compile.sh im -cd compile.sh cd -iup compile.sh iup - -# Test requirements are specified here -[requirements] -waiton ffcall setup - -# Iteration for your tests are controlled by the items section -[items] - -# test_meta is a section for storing additional data on your test -[test_meta] -author matt -owner matt -description Install the iup library if it is not already installed -tags tagone,tagtwo -reviewed never DELETED tests/installall/tests/iupsrclib/untar.logpro Index: tests/installall/tests/iupsrclib/untar.logpro ================================================================== --- tests/installall/tests/iupsrclib/untar.logpro +++ /dev/null @@ -1,8 +0,0 @@ -;; You should have at least one expect:required. This ensures that your process ran -(expect:required in "LogFileBody" > 0 "Put description here" #/put pattern here/) - -;; You may need ignores to suppress false error or warning hits from the later expects -;; NOTE: Order is important here! -(expect:ignore in "LogFileBody" < 99 "Ignore the word error in comments" #/^\/\/.*error/) -(expect:warning in "LogFileBody" = 0 "Any warning" #/warn/) -(expect:error in "LogFileBody" = 0 "Any error" (list #/ERROR/ #/error/i)) ;; but disallow any other errors DELETED tests/installall/tests/iupsrclib/untar.sh Index: tests/installall/tests/iupsrclib/untar.sh ================================================================== --- tests/installall/tests/iupsrclib/untar.sh +++ /dev/null @@ -1,4 +0,0 @@ -#!/usr/bin/env bash - -# Run your step here -source $PREFIX/buildsetup.sh DELETED tests/installall/tests/mmisc/clone.logpro Index: tests/installall/tests/mmisc/clone.logpro ================================================================== --- tests/installall/tests/mmisc/clone.logpro +++ /dev/null @@ -1,8 +0,0 @@ -;; You should have at least one expect:required. This ensures that your process ran -(expect:required in "LogFileBody" > 0 "Output from fossil" #/^repository:\s+/) - -;; You may need ignores to suppress false error or warning hits from the later expects -;; NOTE: Order is important here! -(expect:ignore in "LogFileBody" < 99 "Ignore the word error in comments" #/^\/\/.*error/) -(expect:warning in "LogFileBody" = 0 "Any warning" #/warn/i) -(expect:error in "LogFileBody" = 0 "Any error" (list #/ERROR/ #/error/i)) ;; but disallow any other errors DELETED tests/installall/tests/mmisc/clone.sh Index: tests/installall/tests/mmisc/clone.sh ================================================================== --- tests/installall/tests/mmisc/clone.sh +++ /dev/null @@ -1,11 +0,0 @@ -#!/usr/bin/env bash - -# Run your step here -source $PREFIX/buildsetup.sh - -fossil clone http://www.kiatoa.com/fossils/$FSLPKG $FSLPKG.fossil - -mkdir src -cd src -fossil open ../$FSLPKG.fossil --nested -fossil co ${$FSLPKG}_VERSION} DELETED tests/installall/tests/mmisc/install.logpro Index: tests/installall/tests/mmisc/install.logpro ================================================================== --- tests/installall/tests/mmisc/install.logpro +++ /dev/null @@ -1,9 +0,0 @@ -;; You should have at least one expect:required. This ensures that your process ran -(expect:required in "LogFileBody" > 0 "Always get a chmod at the end of install" #/chmod.*logpro.setup-info/) - -;; You may need ignores to suppress false error or warning hits from the later expects -;; NOTE: Order is important here! -(expect:ignore in "LogFileBody" < 99 "Ignore the word error in comments" #/^\/\/.*error/) -(expect:ignore in "LogFileBody" < 99 "Ignore the word error in setup-error-handling" #/setup-error-handling/) -(expect:warning in "LogFileBody" = 0 "Any warning" #/warn/i) -(expect:error in "LogFileBody" = 0 "Any error" (list #/ERROR/ #/error/i)) ;; but disallow any other errors DELETED tests/installall/tests/mmisc/install.sh Index: tests/installall/tests/mmisc/install.sh ================================================================== --- tests/installall/tests/mmisc/install.sh +++ /dev/null @@ -1,16 +0,0 @@ -#!/usr/bin/env bash - -# Run your step here -source $PREFIX/buildsetup.sh -cd src -if [ $FSLPKG == "logpro" ];then - chicken-install -elif [ $FSLPKG == "stml" ];then - cp install.cfg.template install.cfg - cp requirements.scm.template requirements.scm - make - make install -else - make - make install PREFIX=$PREFIX -fi DELETED tests/installall/tests/mmisc/testconfig Index: tests/installall/tests/mmisc/testconfig ================================================================== --- tests/installall/tests/mmisc/testconfig +++ /dev/null @@ -1,21 +0,0 @@ -# Add additional steps here. Format is "stepname script" -[ezsteps] -clone clone.sh -install install.sh - -# Test requirements are specified here -[requirements] -waiton eggs setup - -# Iteration for your tests are controlled by the items section -[items] -FSLPKG logpro stml megatest - - -# test_meta is a section for storing additional data on your test -[test_meta] -author matt -owner matt -description Install the logpro tool -tags tagone,tagtwo -reviewed never DELETED tests/installall/tests/opensrc/clone.logpro Index: tests/installall/tests/opensrc/clone.logpro ================================================================== --- tests/installall/tests/opensrc/clone.logpro +++ /dev/null @@ -1,8 +0,0 @@ -;; You should have at least one expect:required. This ensures that your process ran -(expect:required in "LogFileBody" > 0 "Output from fossil" (list #/^repository:\s+/ #/comment:/)) - -;; You may need ignores to suppress false error or warning hits from the later expects -;; NOTE: Order is important here! -(expect:ignore in "LogFileBody" < 99 "Ignore the word error in comments" #/^\/\/.*error/) -(expect:warning in "LogFileBody" = 0 "Any warning" #/warn/i) -(expect:error in "LogFileBody" = 0 "Any error" (list #/ERROR/ #/error/i)) ;; but disallow any other errors DELETED tests/installall/tests/opensrc/clone.sh Index: tests/installall/tests/opensrc/clone.sh ================================================================== --- tests/installall/tests/opensrc/clone.sh +++ /dev/null @@ -1,22 +0,0 @@ -#!/usr/bin/env bash - -# Run your step here -source $PREFIX/buildsetup.sh - -parentdir=$MT_LINKTREE/$MT_TARGET/$MT_RUNNAME - -lockfile $parentdir/clone.lock -if [ ! -e $parentdir/opensrc.fossil ];then - fossil clone http://www.kiatoa.com/fossils/opensrc $parentdir/opensrc.fossil -fi - -if [ ! -e $parentdir/src/dbi ];then - mkdir -p $parentdir/src - (cd $parentdir/src;fossil open $parentdir/opensrc.fossil --nested) -else - (cd $parentdir/src;fossil sync;fossil co trunk;fossil status) -fi -rm -f $parentdir/clone.lock - -ln -sf $parentdir/src $MT_TEST_RUN_DIR/src - DELETED tests/installall/tests/opensrc/install.logpro Index: tests/installall/tests/opensrc/install.logpro ================================================================== --- tests/installall/tests/opensrc/install.logpro +++ /dev/null @@ -1,9 +0,0 @@ -;; You should have at least one expect:required. This ensures that your process ran -(expect:required in "LogFileBody" > 0 "Always get a chmod at the end of install" #/chmod.*.setup-info/) - -;; You may need ignores to suppress false error or warning hits from the later expects -;; NOTE: Order is important here! -(expect:ignore in "LogFileBody" < 99 "Ignore the word error in comments" #/^\/\/.*error/) -(expect:ignore in "LogFileBody" < 99 "Ignore the word error in setup-error-handling" #/setup-error-handling/) -(expect:warning in "LogFileBody" = 0 "Any warning" #/warn/i) -(expect:error in "LogFileBody" = 0 "Any error" (list #/ERROR/ #/error/i)) ;; but disallow any other errors DELETED tests/installall/tests/opensrc/install.sh Index: tests/installall/tests/opensrc/install.sh ================================================================== --- tests/installall/tests/opensrc/install.sh +++ /dev/null @@ -1,6 +0,0 @@ -#!/usr/bin/env bash - -# Run your step here -source $PREFIX/buildsetup.sh -cd src/$MODULE_NAME -chicken-install DELETED tests/installall/tests/opensrc/testconfig Index: tests/installall/tests/opensrc/testconfig ================================================================== --- tests/installall/tests/opensrc/testconfig +++ /dev/null @@ -1,20 +0,0 @@ -# Add additional steps here. Format is "stepname script" -[ezsteps] -clone clone.sh -install install.sh - -# Test requirements are specified here -[requirements] -waiton eggs setup sqlite3 - -# Iteration for your tests are controlled by the items section -[items] -MODULE_NAME dbi margs qtree vcd xfig mutils - -# test_meta is a section for storing additional data on your test -[test_meta] -author matt -owner matt -description Install the eggs from the opensrc fossil -tags tagone,tagtwo -reviewed never DELETED tests/installall/tests/setup/setup.logpro Index: tests/installall/tests/setup/setup.logpro ================================================================== --- tests/installall/tests/setup/setup.logpro +++ /dev/null @@ -1,10 +0,0 @@ -;; You should have at least one expect:required. This ensures that your process ran -(expect:required in "LogFileBody" > 0 "ALL DONE" #/ALL DONE$/) - -;; You may need ignores to suppress false error or warning hits from the later expects -;; NOTE: Order is important here! - - -(expect:ignore in "LogFileBody" < 99 "Ignore the word error in comments" #/^\/\/.*error/) -(expect:warning in "LogFileBody" = 0 "Any warning" #/warn/) -(expect:error in "LogFileBody" = 0 "Any error" (list #/ERROR/ #/error/i)) ;; but disallow any other errors DELETED tests/installall/tests/setup/setup.sh Index: tests/installall/tests/setup/setup.sh ================================================================== --- tests/installall/tests/setup/setup.sh +++ /dev/null @@ -1,35 +0,0 @@ -#!/usr/bin/env bash - -# Run your step here - -cksetupsh=$PREFIX/setup-chicken4x.sh -cksetupcsh=$PREFIX/setup-chicken4x.csh -setupsh=$PREFIX/buildsetup.sh - -# make a cache dir -mkdir -p $DOWNLOADS -mkdir -p $PREFIX - -# File for users to source to run chicken -echo "# Source me to setup to to run chicken" > $cksetupsh -echo "export PATH=$PREFIX/bin:\$PATH" > $cksetupsh -echo "export LD_LIBRARY_PATH=$PREFIX/lib" >> $cksetupsh - -# tcsh version -echo "setenv PATH $PREFIX/bin:\$PATH" > $cksetupcsh -echo "setenv LD_LIBRARY_PATH $PREFIX/lib" >> $cksetupcsh - -# File to source for build process -echo "export PATH=$PREFIX/bin:\$PATH" > $setupsh -echo "export LD_LIBRARY_PATH=$PREFIX/lib" >> $setupsh - -if [[ $proxy == "" ]]; then - echo 'Please set the environment variable "proxy" to host.com:port (e.g. foo.com:1234) to use a proxy' -else - echo "export http_proxy=http://$proxy" >> $setupsh - echo "export PROX=\"-proxy $proxy\"" >> $setupsh -fi - -echo "export PREFIX=$PREFIX" >> $setupsh - -echo ALL DONE DELETED tests/installall/tests/setup/testconfig Index: tests/installall/tests/setup/testconfig ================================================================== --- tests/installall/tests/setup/testconfig +++ /dev/null @@ -1,18 +0,0 @@ -# Add additional steps here. Format is "stepname script" -[ezsteps] -setup setup.sh - -# Test requirements are specified here -[requirements] -# priority 10 - -# Iteration for your tests are controlled by the items section -[items] - -# test_meta is a section for storing additional data on your test -[test_meta] -author matt -owner matt -description Download and install chicken scheme -tags tagone,tagtwo -reviewed never DELETED tests/installall/tests/sqlite3/compile.logpro Index: tests/installall/tests/sqlite3/compile.logpro ================================================================== --- tests/installall/tests/sqlite3/compile.logpro +++ /dev/null @@ -1,9 +0,0 @@ -;; You should have at least one expect:required. This ensures that your process ran -(expect:required in "LogFileBody" > 0 "Leaving directory" #/(Leaving directory|Nothing to be done for|creating sqlite3)/) - -;; You may need ignores to suppress false error or warning hits from the later expects -;; NOTE: Order is important here! -(expect:ignore in "LogFileBody" >= 0 "Ignore strerror_r" #/strerror_r/i) -(expect:ignore in "LogFileBody" < 99 "Ignore the word error in comments" #/^\/\/.*error/) -(expect:warning in "LogFileBody" = 0 "Any warning" #/warn/) -(expect:error in "LogFileBody" = 0 "Any error" (list #/ERROR/ #/error/i)) ;; but disallow any other errors DELETED tests/installall/tests/sqlite3/compile.sh Index: tests/installall/tests/sqlite3/compile.sh ================================================================== --- tests/installall/tests/sqlite3/compile.sh +++ /dev/null @@ -1,10 +0,0 @@ -#!/usr/bin/env bash - -# Run your step here - -source $PREFIX/buildsetup.sh - -cd sqlite-autoconf-$SQLITE3_VERSION -./configure --prefix=$PREFIX - -make DELETED tests/installall/tests/sqlite3/download.logpro Index: tests/installall/tests/sqlite3/download.logpro ================================================================== --- tests/installall/tests/sqlite3/download.logpro +++ /dev/null @@ -1,8 +0,0 @@ -;; You should have at least one expect:required. This ensures that your process ran -(expect:required in "LogFileBody" > 0 "sqlite-autoconf" #/sqlite-autoconf/) - -;; You may need ignores to suppress false error or warning hits from the later expects -;; NOTE: Order is important here! -(expect:ignore in "LogFileBody" < 99 "Ignore the word error in comments" #/^\/\/.*error/) -(expect:warning in "LogFileBody" = 0 "Any warning" #/warn/) -(expect:error in "LogFileBody" = 0 "Any error" (list #/ERROR/ #/error/i)) ;; but disallow any other errors DELETED tests/installall/tests/sqlite3/download.sh Index: tests/installall/tests/sqlite3/download.sh ================================================================== --- tests/installall/tests/sqlite3/download.sh +++ /dev/null @@ -1,14 +0,0 @@ -#!/usr/bin/env bash - -# Run your step here - -source $PREFIX/buildsetup.sh - -echo Install sqlite3 -if ! [[ -e ${DOWNLOADS}/sqlite-autoconf-${SQLITE3_VERSION}.tar.gz ]]; then - (cd ${DOWNLOADS};wget http://www.sqlite.org/sqlite-autoconf-${SQLITE3_VERSION}.tar.gz) -fi - -tar xfz ${DOWNLOADS}/sqlite-autoconf-${SQLITE3_VERSION}.tar.gz - -ls -l sqlite-autoconf-${SQLITE3_VERSION}.tar.gz DELETED tests/installall/tests/sqlite3/install.logpro Index: tests/installall/tests/sqlite3/install.logpro ================================================================== --- tests/installall/tests/sqlite3/install.logpro +++ /dev/null @@ -1,8 +0,0 @@ -;; You should have at least one expect:required. This ensures that your process ran -(expect:required in "LogFileBody" > 0 "Leaving directory" #/Leaving directory/) - -;; You may need ignores to suppress false error or warning hits from the later expects -;; NOTE: Order is important here! -(expect:ignore in "LogFileBody" < 99 "Ignore the word error in comments" #/^\/\/.*error/) -(expect:warning in "LogFileBody" = 0 "Any warning" #/warn/) -(expect:error in "LogFileBody" = 0 "Any error" (list #/ERROR/ #/error/i)) ;; but disallow any other errors DELETED tests/installall/tests/sqlite3/install.sh Index: tests/installall/tests/sqlite3/install.sh ================================================================== --- tests/installall/tests/sqlite3/install.sh +++ /dev/null @@ -1,9 +0,0 @@ -#!/usr/bin/env bash - -# Run your step here - -source $PREFIX/buildsetup.sh - -cd sqlite-autoconf-$SQLITE3_VERSION -make install - DELETED tests/installall/tests/sqlite3/installegg.logpro Index: tests/installall/tests/sqlite3/installegg.logpro ================================================================== --- tests/installall/tests/sqlite3/installegg.logpro +++ /dev/null @@ -1,9 +0,0 @@ -;; You should have at least one expect:required. This ensures that your process ran -(expect:required in "LogFileBody" > 0 "chmod sqlite3" #/chmod.*sqlite3/) - -;; You may need ignores to suppress false error or warning hits from the later expects -;; NOTE: Order is important here! -(expect:ignore in "LogFileBody" >= 0 "Ignore setup-error-handling" #/setup-error-handling/) -(expect:ignore in "LogFileBody" < 99 "Ignore the word error in comments" #/^\/\/.*error/) -(expect:warning in "LogFileBody" = 0 "Any warning" #/warn/) -(expect:error in "LogFileBody" = 0 "Any error" (list #/ERROR/ #/error/i)) ;; but disallow any other errors DELETED tests/installall/tests/sqlite3/installegg.sh Index: tests/installall/tests/sqlite3/installegg.sh ================================================================== --- tests/installall/tests/sqlite3/installegg.sh +++ /dev/null @@ -1,7 +0,0 @@ -#!/usr/bin/env bash - -# Run your step here - -source $PREFIX/buildsetup.sh - -CSC_OPTIONS="-I$PREFIX/include -L$PREFIX/lib" $PREFIX/bin/chicken-install $PROX sqlite3 DELETED tests/installall/tests/sqlite3/testconfig Index: tests/installall/tests/sqlite3/testconfig ================================================================== --- tests/installall/tests/sqlite3/testconfig +++ /dev/null @@ -1,24 +0,0 @@ -# Add additional steps here. Format is "stepname script" -[ezsteps] -download download.sh -compile compile.sh -install install.sh -installegg installegg.sh - -# Test requirements are specified here -[requirements] -# We waiton chicken because this one installs the egg. It would behove us to split this -# into two tests ... -waiton tougheggs -priority 2 - -# Iteration for your tests are controlled by the items section -[items] - -# test_meta is a section for storing additional data on your test -[test_meta] -author matt -owner matt -description Install sqlite3 library for systems where it is not installed -tags tagone,tagtwo -reviewed never DELETED tests/installall/tests/tougheggs/install.logpro Index: tests/installall/tests/tougheggs/install.logpro ================================================================== --- tests/installall/tests/tougheggs/install.logpro +++ /dev/null @@ -1,9 +0,0 @@ -;; You should have at least one expect:required. This ensures that your process ran -(expect:required in "LogFileBody" > 0 "Last thing done is chmod ..." #/chmod /) - -;; You may need ignores to suppress false error or warning hits from the later expects -;; NOTE: Order is important here! -(expect:ignore in "LogFileBody" >= 0 "Ignore someword-errors" #/\w+-error/) -(expect:ignore in "LogFileBody" < 99 "Ignore the word error in comments" #/^\/\/.*error/) -(expect:warning in "LogFileBody" = 0 "Any warning" #/warn/) -(expect:error in "LogFileBody" = 0 "Any error" (list #/ERROR/ #/error/i)) ;; but disallow any other errors DELETED tests/installall/tests/tougheggs/install.sh Index: tests/installall/tests/tougheggs/install.sh ================================================================== --- tests/installall/tests/tougheggs/install.sh +++ /dev/null @@ -1,9 +0,0 @@ -#!/usr/bin/env bash - -# Run your step here - -source $PREFIX/buildsetup.sh - -lockfile $PREFIX/eggs.lock -$PREFIX/bin/chicken-install $PROX $EGG_NAME -rm -f $PREFIX/eggs.lock DELETED tests/installall/tests/tougheggs/testconfig Index: tests/installall/tests/tougheggs/testconfig ================================================================== --- tests/installall/tests/tougheggs/testconfig +++ /dev/null @@ -1,19 +0,0 @@ -# Add additional steps here. Format is "stepname script" -[ezsteps] -install install.sh - -# Test requirements are specified here -[requirements] -waiton eggs - -# Iteration for your tests are controlled by the items section -[items] -EGG_NAME intarweb http-client awful uri-common spiffy-request-vars spiffy apropos spiffy-directory-listing - -# test_meta is a section for storing additional data on your test -[test_meta] -author matt -owner matt -description Download and install eggs with no significant prerequisites -tags tagone,tagtwo -reviewed never DELETED tests/installall/tests/zmq/install.logpro Index: tests/installall/tests/zmq/install.logpro ================================================================== --- tests/installall/tests/zmq/install.logpro +++ /dev/null @@ -1,8 +0,0 @@ -;; You should have at least one expect:required. This ensures that your process ran -(expect:required in "LogFileBody" > 0 "Put description here" #/put pattern here/) - -;; You may need ignores to suppress false error or warning hits from the later expects -;; NOTE: Order is important here! -(expect:ignore in "LogFileBody" < 99 "Ignore the word error in comments" #/^\/\/.*error/) -(expect:warning in "LogFileBody" = 0 "Any warning" #/warn/) -(expect:error in "LogFileBody" = 0 "Any error" (list #/ERROR/ #/error/i)) ;; but disallow any other errors DELETED tests/installall/tests/zmq/install.sh Index: tests/installall/tests/zmq/install.sh ================================================================== --- tests/installall/tests/zmq/install.sh +++ /dev/null @@ -1,4 +0,0 @@ -#!/usr/bin/env bash - -# Run your step here -source $PREFIX/buildsetup.sh DELETED tests/installall/tests/zmq/testconfig Index: tests/installall/tests/zmq/testconfig ================================================================== --- tests/installall/tests/zmq/testconfig +++ /dev/null @@ -1,18 +0,0 @@ -# Add additional steps here. Format is "stepname script" -[ezsteps] -install install.sh - -# Test requirements are specified here -[requirements] -waiton zmqlib chicken setup - -# Iteration for your tests are controlled by the items section -[items] - -# test_meta is a section for storing additional data on your test -[test_meta] -author matt -owner matt -description Install the zmq egg -tags tagone,tagtwo -reviewed never DELETED tests/installall/tests/zmqlib/compile.logpro Index: tests/installall/tests/zmqlib/compile.logpro ================================================================== --- tests/installall/tests/zmqlib/compile.logpro +++ /dev/null @@ -1,8 +0,0 @@ -;; You should have at least one expect:required. This ensures that your process ran -(expect:required in "LogFileBody" > 0 "Put description here" #/put pattern here/) - -;; You may need ignores to suppress false error or warning hits from the later expects -;; NOTE: Order is important here! -(expect:ignore in "LogFileBody" < 99 "Ignore the word error in comments" #/^\/\/.*error/) -(expect:warning in "LogFileBody" = 0 "Any warning" #/warn/) -(expect:error in "LogFileBody" = 0 "Any error" (list #/ERROR/ #/error/i)) ;; but disallow any other errors DELETED tests/installall/tests/zmqlib/compile.sh Index: tests/installall/tests/zmqlib/compile.sh ================================================================== --- tests/installall/tests/zmqlib/compile.sh +++ /dev/null @@ -1,4 +0,0 @@ -#!/usr/bin/env bash - -# Run your step here -source $PREFIX/buildsetup.sh DELETED tests/installall/tests/zmqlib/download.logpro Index: tests/installall/tests/zmqlib/download.logpro ================================================================== --- tests/installall/tests/zmqlib/download.logpro +++ /dev/null @@ -1,8 +0,0 @@ -;; You should have at least one expect:required. This ensures that your process ran -(expect:required in "LogFileBody" > 0 "Put description here" #/put pattern here/) - -;; You may need ignores to suppress false error or warning hits from the later expects -;; NOTE: Order is important here! -(expect:ignore in "LogFileBody" < 99 "Ignore the word error in comments" #/^\/\/.*error/) -(expect:warning in "LogFileBody" = 0 "Any warning" #/warn/) -(expect:error in "LogFileBody" = 0 "Any error" (list #/ERROR/ #/error/i)) ;; but disallow any other errors DELETED tests/installall/tests/zmqlib/download.sh Index: tests/installall/tests/zmqlib/download.sh ================================================================== --- tests/installall/tests/zmqlib/download.sh +++ /dev/null @@ -1,4 +0,0 @@ -#!/usr/bin/env bash - -# Run your step here -source $PREFIX/buildsetup.sh DELETED tests/installall/tests/zmqlib/install.logpro Index: tests/installall/tests/zmqlib/install.logpro ================================================================== --- tests/installall/tests/zmqlib/install.logpro +++ /dev/null @@ -1,8 +0,0 @@ -;; You should have at least one expect:required. This ensures that your process ran -(expect:required in "LogFileBody" > 0 "Put description here" #/put pattern here/) - -;; You may need ignores to suppress false error or warning hits from the later expects -;; NOTE: Order is important here! -(expect:ignore in "LogFileBody" < 99 "Ignore the word error in comments" #/^\/\/.*error/) -(expect:warning in "LogFileBody" = 0 "Any warning" #/warn/) -(expect:error in "LogFileBody" = 0 "Any error" (list #/ERROR/ #/error/i)) ;; but disallow any other errors DELETED tests/installall/tests/zmqlib/install.sh Index: tests/installall/tests/zmqlib/install.sh ================================================================== --- tests/installall/tests/zmqlib/install.sh +++ /dev/null @@ -1,5 +0,0 @@ -#!/usr/bin/env bash - -# Run your step here - -source $PREFIX/buildsetup.sh DELETED tests/installall/tests/zmqlib/testconfig Index: tests/installall/tests/zmqlib/testconfig ================================================================== --- tests/installall/tests/zmqlib/testconfig +++ /dev/null @@ -1,21 +0,0 @@ -# Add additional steps here. Format is "stepname script" -[ezsteps] -download download.sh -untar untar.sh -compile compile.sh -install install.sh - -# Test requirements are specified here -[requirements] -waiton setup - -# Iteration for your tests are controlled by the items section -[items] - -# test_meta is a section for storing additional data on your test -[test_meta] -author matt -owner matt -description Install the zmq library if it doesn't already exist -tags tagone,tagtwo -reviewed never DELETED tests/installall/tests/zmqlib/untar.logpro Index: tests/installall/tests/zmqlib/untar.logpro ================================================================== --- tests/installall/tests/zmqlib/untar.logpro +++ /dev/null @@ -1,8 +0,0 @@ -;; You should have at least one expect:required. This ensures that your process ran -(expect:required in "LogFileBody" > 0 "Put description here" #/put pattern here/) - -;; You may need ignores to suppress false error or warning hits from the later expects -;; NOTE: Order is important here! -(expect:ignore in "LogFileBody" < 99 "Ignore the word error in comments" #/^\/\/.*error/) -(expect:warning in "LogFileBody" = 0 "Any warning" #/warn/) -(expect:error in "LogFileBody" = 0 "Any error" (list #/ERROR/ #/error/i)) ;; but disallow any other errors DELETED tests/installall/tests/zmqlib/untar.sh Index: tests/installall/tests/zmqlib/untar.sh ================================================================== --- tests/installall/tests/zmqlib/untar.sh +++ /dev/null @@ -1,4 +0,0 @@ -#!/usr/bin/env bash - -# Run your step here -source $PREFIX/buildsetup.sh Index: tests/manual.sh ================================================================== --- tests/manual.sh +++ tests/manual.sh @@ -1,1 +1,18 @@ +# Copyright 2006-2017, Matthew Welland. +# +# This file is part of Megatest. +# +# Megatest is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# Megatest is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with Megatest. If not, see . + (cd ..;make install) && `realpath ../bin/megatest` -runtests manual_example :sysname ubuntu :fsname afs :datapath none :runname testing -setvars TARGETDISPLAY=:0,TARGETHOST=localhost,TARGETDIR=/tmp/blah,TARGETUSER=matt Index: tests/mintest/megatest.config ================================================================== --- tests/mintest/megatest.config +++ tests/mintest/megatest.config @@ -1,17 +1,33 @@ +# Copyright 2006-2017, Matthew Welland. +# +# This file is part of Megatest. +# +# Megatest is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# Megatest is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with Megatest. If not, see . + [fields] X TEXT [setup] max_concurrent_jobs 50 linktree #{getenv MT_RUN_AREA_HOME}/linktree -transport http [server] port 8090 [jobtools] useshell yes -launcher nbfind +launcher nbfake [disks] disk0 #{getenv PWD}/runs Index: tests/mintest/runconfigs.config ================================================================== --- tests/mintest/runconfigs.config +++ tests/mintest/runconfigs.config @@ -1,5 +1,22 @@ +# Copyright 2006-2017, Matthew Welland. +# +# This file is part of Megatest. +# +# Megatest is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# Megatest is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with Megatest. If not, see . + [default] ALLTESTS see this variable # Your variables here are grouped by targets [SYSTEM/RELEASE] [a] Index: tests/mintest/tests/a/testconfig ================================================================== --- tests/mintest/tests/a/testconfig +++ tests/mintest/tests/a/testconfig @@ -1,6 +1,30 @@ +# Copyright 2006-2017, Matthew Welland. +# +# This file is part of Megatest. +# +# Megatest is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# Megatest is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with Megatest. If not, see . + # Add steps here. Format is "stepname script" [ezsteps] step1 echo SUCCESS +# step1 ((xterm&);echo SUCCESS) +# step2 xterm_and_success + +[scripts] +xterm_and_success #!/bin/bash + xterm -T step2 & + echo SUCCESS [requirements] waiton b Index: tests/mintest/tests/a1/testconfig ================================================================== --- tests/mintest/tests/a1/testconfig +++ tests/mintest/tests/a1/testconfig @@ -1,5 +1,22 @@ +# Copyright 2006-2017, Matthew Welland. +# +# This file is part of Megatest. +# +# Megatest is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# Megatest is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with Megatest. If not, see . + # Add steps here. Format is "stepname script" [ezsteps] step1 echo SUCCESS [requirements] Index: tests/mintest/tests/b/testconfig ================================================================== --- tests/mintest/tests/b/testconfig +++ tests/mintest/tests/b/testconfig @@ -1,5 +1,22 @@ +# Copyright 2006-2017, Matthew Welland. +# +# This file is part of Megatest. +# +# Megatest is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# Megatest is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with Megatest. If not, see . + # Add steps here. Format is "stepname script" [ezsteps] step1 echo SUCCESS [requirements] Index: tests/mintest/tests/b1/testconfig ================================================================== --- tests/mintest/tests/b1/testconfig +++ tests/mintest/tests/b1/testconfig @@ -1,5 +1,22 @@ +# Copyright 2006-2017, Matthew Welland. +# +# This file is part of Megatest. +# +# Megatest is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# Megatest is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with Megatest. If not, see . + # Add steps here. Format is "stepname script" [ezsteps] step1 echo SUCCESS [requirements] Index: tests/mintest/tests/c/testconfig ================================================================== --- tests/mintest/tests/c/testconfig +++ tests/mintest/tests/c/testconfig @@ -1,5 +1,22 @@ +# Copyright 2006-2017, Matthew Welland. +# +# This file is part of Megatest. +# +# Megatest is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# Megatest is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with Megatest. If not, see . + # Add steps here. Format is "stepname script" [ezsteps] step1 echo SUCCESS [requirements] Index: tests/mintest/tests/c1/testconfig ================================================================== --- tests/mintest/tests/c1/testconfig +++ tests/mintest/tests/c1/testconfig @@ -1,5 +1,22 @@ +# Copyright 2006-2017, Matthew Welland. +# +# This file is part of Megatest. +# +# Megatest is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# Megatest is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with Megatest. If not, see . + # Add steps here. Format is "stepname script" [ezsteps] step1 echo SUCCESS [requirements] Index: tests/mintest/tests/d/testconfig ================================================================== --- tests/mintest/tests/d/testconfig +++ tests/mintest/tests/d/testconfig @@ -1,5 +1,22 @@ +# Copyright 2006-2017, Matthew Welland. +# +# This file is part of Megatest. +# +# Megatest is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# Megatest is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with Megatest. If not, see . + # Add steps here. Format is "stepname script" [ezsteps] step1 echo SUCCESS [requirements] Index: tests/mintest/tests/d1fail/testconfig ================================================================== --- tests/mintest/tests/d1fail/testconfig +++ tests/mintest/tests/d1fail/testconfig @@ -1,5 +1,22 @@ +# Copyright 2006-2017, Matthew Welland. +# +# This file is part of Megatest. +# +# Megatest is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# Megatest is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with Megatest. If not, see . + # Add steps here. Format is "stepname script" [ezsteps] step1 echo SUCCESS step2 exit 123 Index: tests/mintest/tests/e/testconfig ================================================================== --- tests/mintest/tests/e/testconfig +++ tests/mintest/tests/e/testconfig @@ -1,4 +1,21 @@ +# Copyright 2006-2017, Matthew Welland. +# +# This file is part of Megatest. +# +# Megatest is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# Megatest is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with Megatest. If not, see . + # Add steps here. Format is "stepname script" [ezsteps] step1 echo SUCCESS Index: tests/mintest/tests/e1/testconfig ================================================================== --- tests/mintest/tests/e1/testconfig +++ tests/mintest/tests/e1/testconfig @@ -1,4 +1,21 @@ +# Copyright 2006-2017, Matthew Welland. +# +# This file is part of Megatest. +# +# Megatest is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# Megatest is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with Megatest. If not, see . + # Add steps here. Format is "stepname script" [ezsteps] step1 echo SUCCESS Index: tests/mintest/tests/f/testconfig ================================================================== --- tests/mintest/tests/f/testconfig +++ tests/mintest/tests/f/testconfig @@ -1,5 +1,22 @@ +# Copyright 2006-2017, Matthew Welland. +# +# This file is part of Megatest. +# +# Megatest is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# Megatest is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with Megatest. If not, see . + # Add steps here. Format is "stepname script" [ezsteps] step1 echo SUCCESS [requirements] Index: tests/mintest/tests/g/testconfig ================================================================== --- tests/mintest/tests/g/testconfig +++ tests/mintest/tests/g/testconfig @@ -1,5 +1,22 @@ +# Copyright 2006-2017, Matthew Welland. +# +# This file is part of Megatest. +# +# Megatest is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# Megatest is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with Megatest. If not, see . + # Add steps here. Format is "stepname script" [ezsteps] step1 echo SUCCESS [requirements] Index: tests/mintest/tests/h/testconfig ================================================================== --- tests/mintest/tests/h/testconfig +++ tests/mintest/tests/h/testconfig @@ -1,5 +1,22 @@ +# Copyright 2006-2017, Matthew Welland. +# +# This file is part of Megatest. +# +# Megatest is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# Megatest is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with Megatest. If not, see . + # Add steps here. Format is "stepname script" [ezsteps] step1 echo SUCCESS [requirements] Index: tests/mintest/tests/i/testconfig ================================================================== --- tests/mintest/tests/i/testconfig +++ tests/mintest/tests/i/testconfig @@ -1,5 +1,22 @@ +# Copyright 2006-2017, Matthew Welland. +# +# This file is part of Megatest. +# +# Megatest is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# Megatest is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with Megatest. If not, see . + # Add steps here. Format is "stepname script" [ezsteps] step1 echo SUCCESS [requirements] Index: tests/mintest/tests/j/testconfig ================================================================== --- tests/mintest/tests/j/testconfig +++ tests/mintest/tests/j/testconfig @@ -1,5 +1,22 @@ +# Copyright 2006-2017, Matthew Welland. +# +# This file is part of Megatest. +# +# Megatest is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# Megatest is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with Megatest. If not, see . + # Add steps here. Format is "stepname script" [ezsteps] step1 echo SUCCESS [requirements] Index: tests/mintest/tests/k/testconfig ================================================================== --- tests/mintest/tests/k/testconfig +++ tests/mintest/tests/k/testconfig @@ -1,5 +1,22 @@ +# Copyright 2006-2017, Matthew Welland. +# +# This file is part of Megatest. +# +# Megatest is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# Megatest is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with Megatest. If not, see . + # Add steps here. Format is "stepname script" [ezsteps] step1 echo SUCCESS [requirements] Index: tests/mintest/tests/l/testconfig ================================================================== --- tests/mintest/tests/l/testconfig +++ tests/mintest/tests/l/testconfig @@ -1,5 +1,22 @@ +# Copyright 2006-2017, Matthew Welland. +# +# This file is part of Megatest. +# +# Megatest is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# Megatest is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with Megatest. If not, see . + # Add steps here. Format is "stepname script" [ezsteps] step1 echo SUCCESS [requirements] Index: tests/ods-test.scm ================================================================== --- tests/ods-test.scm +++ tests/ods-test.scm @@ -1,5 +1,22 @@ +;; Copyright 2006-2017, Matthew Welland. +;; +;; This file is part of Megatest. +;; +;; Megatest is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. +;; +;; Megatest is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with Megatest. If not, see . + (load "ods.scm") (ods:list->ods "testing" "testing.ods" Index: tests/release/Makefile ================================================================== --- tests/release/Makefile +++ tests/release/Makefile @@ -1,6 +1,21 @@ - +# Copyright 2006-2017, Matthew Welland. +# +# This file is part of Megatest. +# +# Megatest is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# Megatest is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with Megatest. If not, see . dashboard : compile dashboard -rows 24 & compile : runs Index: tests/release/megatest.config ================================================================== --- tests/release/megatest.config +++ tests/release/megatest.config @@ -1,5 +1,22 @@ +# Copyright 2006-2017, Matthew Welland. +# +# This file is part of Megatest. +# +# Megatest is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# Megatest is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with Megatest. If not, see . + [fields] release TEXT iteration TEXT [setup] Index: tests/release/runconfigs.config ================================================================== --- tests/release/runconfigs.config +++ tests/release/runconfigs.config @@ -1,5 +1,22 @@ +# Copyright 2006-2017, Matthew Welland. +# +# This file is part of Megatest. +# +# Megatest is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# Megatest is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with Megatest. If not, see . + [default] MTRUNNER #{shell readlink -f #{getenv MT_RUN_AREA_HOME}/../../utils/mtrunner} MTTESTDIR #{shell readlink -f #{getenv MT_RUN_AREA_HOME}/..} MTPATH #{shell readlink -f #{getenv MT_RUN_AREA_HOME}/../../bin} Index: tests/release/tests/dependencies/simpleresults.logpro ================================================================== --- tests/release/tests/dependencies/simpleresults.logpro +++ tests/release/tests/dependencies/simpleresults.logpro @@ -1,8 +1,24 @@ ;; (c) 2006,2007,2008,2009 Matthew Welland matt@kiatoa.com ;; -;; License GPL. +;; Copyright 2006-2017, Matthew Welland. +;; +;; This file is part of Megatest. +;; +;; Megatest is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. +;; +;; Megatest is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with Megatest. If not, see . + (define logbody "LogFileBody") (define pass-specs '( ;; testname num-expected max-runtime ("setup" 1 20) Index: tests/release/tests/dependencies/testconfig ================================================================== --- tests/release/tests/dependencies/testconfig +++ tests/release/tests/dependencies/testconfig @@ -1,5 +1,22 @@ +# Copyright 2006-2017, Matthew Welland. +# +# This file is part of Megatest. +# +# Megatest is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# Megatest is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with Megatest. If not, see . + # test2 from the tests/Makefile [var] tname itemwait Index: tests/release/tests/fullrun/results.logpro ================================================================== --- tests/release/tests/fullrun/results.logpro +++ tests/release/tests/fullrun/results.logpro @@ -1,8 +1,24 @@ ;; (c) 2006,2007,2008,2009 Matthew Welland matt@kiatoa.com ;; -;; License GPL. +;; Copyright 2006-2017, Matthew Welland. +;; +;; This file is part of Megatest. +;; +;; Megatest is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. +;; +;; Megatest is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with Megatest. If not, see . + (define logbody "LogFileBody") (define pass-specs '( ;; testname num-expected max-runtime ("exit_0" 1 20) Index: tests/release/tests/fullrun/testconfig ================================================================== --- tests/release/tests/fullrun/testconfig +++ tests/release/tests/fullrun/testconfig @@ -1,5 +1,22 @@ +# Copyright 2006-2017, Matthew Welland. +# +# This file is part of Megatest. +# +# Megatest is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# Megatest is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with Megatest. If not, see . + [ezsteps] cleantop $MTRUNNER $MTTESTDIR/fullrun $MTPATH megatest -remove-runs -target ubuntu/nfs/none -runname release_toplevel -testpatt % runall $MTRUNNER $MTTESTDIR/fullrun $MTPATH megatest -run -testpatt % -target ubuntu/nfs/none -runname release_toplevel -runwait runtop $MTRUNNER $MTTESTDIR/fullrun $MTPATH megatest -run -testpatt all_toplevel -target ubuntu/nfs/none -runname release_toplevel -rerun FAIL -preclean -runwait results $MTRUNNER $MTTESTDIR/fullrun $MTPATH megatest -list-runs release_toplevel -target ubuntu/nfs/none -runname release_toplevel Index: tests/release/tests/itemwait/testconfig ================================================================== --- tests/release/tests/itemwait/testconfig +++ tests/release/tests/itemwait/testconfig @@ -1,5 +1,22 @@ +# Copyright 2006-2017, Matthew Welland. +# +# This file is part of Megatest. +# +# Megatest is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# Megatest is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with Megatest. If not, see . + # test2 from the tests/Makefile [var] tname itemwait Index: tests/release/tests/itemwait/watchrun.sh ================================================================== --- tests/release/tests/itemwait/watchrun.sh +++ tests/release/tests/itemwait/watchrun.sh @@ -1,7 +1,24 @@ #!/bin/bash +# Copyright 2006-2017, Matthew Welland. +# +# This file is part of Megatest. +# +# Megatest is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# Megatest is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with Megatest. If not, see . + runname=$1 pass=no alldone=no while [[ $alldone == no ]];do Index: tests/release/tests/rollup/firstres.logpro ================================================================== --- tests/release/tests/rollup/firstres.logpro +++ tests/release/tests/rollup/firstres.logpro @@ -1,8 +1,23 @@ ;; (c) 2006,2007,2008,2009 Matthew Welland matt@kiatoa.com ;; -;; License GPL. +;; Copyright 2006-2017, Matthew Welland. +;; +;; This file is part of Megatest. +;; +;; Megatest is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. +;; +;; Megatest is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with Megatest. If not, see . (define logbody "LogFileBody") (define pass-specs '( ;; testname num-expected max-runtime ;; ("exit_0" 1 20) Index: tests/release/tests/rollup/results.logpro ================================================================== --- tests/release/tests/rollup/results.logpro +++ tests/release/tests/rollup/results.logpro @@ -1,8 +1,23 @@ ;; (c) 2006,2007,2008,2009 Matthew Welland matt@kiatoa.com ;; -;; License GPL. +;; Copyright 2006-2017, Matthew Welland. +;; +;; This file is part of Megatest. +;; +;; Megatest is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. +;; +;; Megatest is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with Megatest. If not, see . (define logbody "LogFileBody") (define pass-specs '( ;; testname num-expected max-runtime ;; ("exit_0" 1 20) Index: tests/release/tests/rollup/testconfig ================================================================== --- tests/release/tests/rollup/testconfig +++ tests/release/tests/rollup/testconfig @@ -1,5 +1,22 @@ +# Copyright 2006-2017, Matthew Welland. +# +# This file is part of Megatest. +# +# Megatest is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# Megatest is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with Megatest. If not, see . + # test2 from the tests/Makefile [var] tname rollup Index: tests/release/tests/test2/results.logpro ================================================================== --- tests/release/tests/test2/results.logpro +++ tests/release/tests/test2/results.logpro @@ -1,8 +1,23 @@ ;; (c) 2006,2007,2008,2009 Matthew Welland matt@kiatoa.com ;; -;; License GPL. +;; Copyright 2006-2017, Matthew Welland. +;; +;; This file is part of Megatest. +;; +;; Megatest is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. +;; +;; Megatest is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with Megatest. If not, see . (define logbody "LogFileBody") (define pass-specs '( ;; testname num-expected max-runtime ;; ("exit_0" 1 20) Index: tests/release/tests/test2/results_a.logpro ================================================================== --- tests/release/tests/test2/results_a.logpro +++ tests/release/tests/test2/results_a.logpro @@ -1,8 +1,24 @@ ;; (c) 2006,2007,2008,2009 Matthew Welland matt@kiatoa.com ;; -;; License GPL. +;; Copyright 2006-2017, Matthew Welland. +;; +;; This file is part of Megatest. +;; +;; Megatest is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. +;; +;; Megatest is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with Megatest. If not, see . + (define logbody "LogFileBody") (define pass-specs '( ;; testname num-expected max-runtime ;; ("exit_0" 1 20) Index: tests/release/tests/test2/results_b.logpro ================================================================== --- tests/release/tests/test2/results_b.logpro +++ tests/release/tests/test2/results_b.logpro @@ -1,8 +1,23 @@ ;; (c) 2006,2007,2008,2009 Matthew Welland matt@kiatoa.com ;; -;; License GPL. +;; Copyright 2006-2017, Matthew Welland. +;; +;; This file is part of Megatest. +;; +;; Megatest is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. +;; +;; Megatest is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with Megatest. If not, see . (define logbody "LogFileBody") (define pass-specs '( ;; testname num-expected max-runtime ;; ("exit_0" 1 20) Index: tests/release/tests/test2/testconfig ================================================================== --- tests/release/tests/test2/testconfig +++ tests/release/tests/test2/testconfig @@ -1,5 +1,22 @@ +# Copyright 2006-2017, Matthew Welland. +# +# This file is part of Megatest. +# +# Megatest is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# Megatest is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with Megatest. If not, see . + # test2 from the tests/Makefile [var] tname test2 mtpath #{shell readlink -f ../../bin} Index: tests/release/tests/testpatt/cleanres.logpro ================================================================== --- tests/release/tests/testpatt/cleanres.logpro +++ tests/release/tests/testpatt/cleanres.logpro @@ -1,8 +1,23 @@ ;; (c) 2006,2007,2008,2009 Matthew Welland matt@kiatoa.com ;; -;; License GPL. +;; Copyright 2006-2017, Matthew Welland. +;; +;; This file is part of Megatest. +;; +;; Megatest is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. +;; +;; Megatest is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with Megatest. If not, see . (define logbody "LogFileBody") (define pass-specs '( ;; testname num-expected max-runtime ;; ("exit_0" 1 20) Index: tests/release/tests/testpatt/results.logpro ================================================================== --- tests/release/tests/testpatt/results.logpro +++ tests/release/tests/testpatt/results.logpro @@ -1,8 +1,24 @@ ;; (c) 2006,2007,2008,2009 Matthew Welland matt@kiatoa.com ;; -;; License GPL. +;; Copyright 2006-2017, Matthew Welland. +;; +;; This file is part of Megatest. +;; +;; Megatest is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. +;; +;; Megatest is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with Megatest. If not, see . + (define logbody "LogFileBody") (define pass-specs '( ;; testname num-expected max-runtime ;; ("exit_0" 1 20) Index: tests/release/tests/testpatt/testconfig ================================================================== --- tests/release/tests/testpatt/testconfig +++ tests/release/tests/testpatt/testconfig @@ -1,5 +1,22 @@ +# Copyright 2006-2017, Matthew Welland. +# +# This file is part of Megatest. +# +# Megatest is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# Megatest is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with Megatest. If not, see . + [ezsteps] clean $MTRUNNER $MTTESTDIR/fullrun $MTPATH megatest -remove-runs -testpatt % -target ubuntu/nfs/none -runname release_testpatt cleanres $MTRUNNER $MTTESTDIR/fullrun $MTPATH megatest -list-runs release_testpatt -target ubuntu/nfs/none runitems $MTRUNNER $MTTESTDIR/fullrun $MTPATH megatest -run -testpatt runfirst/%2 -target ubuntu/nfs/none -runname release_testpatt Index: tests/release/tests/testpatt_envvar/results.logpro ================================================================== --- tests/release/tests/testpatt_envvar/results.logpro +++ tests/release/tests/testpatt_envvar/results.logpro @@ -1,8 +1,24 @@ ;; (c) 2006,2007,2008,2009 Matthew Welland matt@kiatoa.com ;; -;; License GPL. +;; Copyright 2006-2017, Matthew Welland. +;; +;; This file is part of Megatest. +;; +;; Megatest is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. +;; +;; Megatest is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with Megatest. If not, see . + (define logbody "LogFileBody") (define pass-specs '( ;; testname num-expected max-runtime ("exit_0" 1 20) Index: tests/release/tests/testpatt_envvar/testconfig ================================================================== --- tests/release/tests/testpatt_envvar/testconfig +++ tests/release/tests/testpatt_envvar/testconfig @@ -1,5 +1,22 @@ +# Copyright 2006-2017, Matthew Welland. +# +# This file is part of Megatest. +# +# Megatest is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# Megatest is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with Megatest. If not, see . + [var] targ -target ubuntu/nfs/all_toplevel tp -testpatt % [ezsteps] Index: tests/release/tests/toprun/results.logpro ================================================================== --- tests/release/tests/toprun/results.logpro +++ tests/release/tests/toprun/results.logpro @@ -1,8 +1,24 @@ ;; (c) 2006,2007,2008,2009 Matthew Welland matt@kiatoa.com ;; -;; License GPL. +;; Copyright 2006-2017, Matthew Welland. +;; +;; This file is part of Megatest. +;; +;; Megatest is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. +;; +;; Megatest is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with Megatest. If not, see . + (define logbody "LogFileBody") (define pass-specs '( ;; testname num-expected max-runtime ("exit_0" 1 20) Index: tests/release/tests/toprun/testconfig ================================================================== --- tests/release/tests/toprun/testconfig +++ tests/release/tests/toprun/testconfig @@ -1,5 +1,22 @@ +# Copyright 2006-2017, Matthew Welland. +# +# This file is part of Megatest. +# +# Megatest is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# Megatest is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with Megatest. If not, see . + [misc] rname release_toprun rdir $MTTESTDIR/fullrun [ezsteps] Index: tests/resources/ruby/librunscript.rb ================================================================== --- tests/resources/ruby/librunscript.rb +++ tests/resources/ruby/librunscript.rb @@ -1,7 +1,24 @@ # This is the library of stuff for megatest +# Copyright 2006-2017, Matthew Welland. +# +# This file is part of Megatest. +# +# Megatest is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# Megatest is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with Megatest. If not, see . + def run_and_record(stepname, cmd, checks) system "megatest -step #{stepname} :state start :status n/a" system cmd exitcode=$? if exitcode==0 Index: tests/rununittest.sh ================================================================== --- tests/rununittest.sh +++ tests/rununittest.sh @@ -1,19 +1,38 @@ #!/bin/bash +# Copyright 2006-2017, Matthew Welland. +# +# This file is part of Megatest. +# +# Megatest is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# Megatest is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with Megatest. If not, see . + # Usage: rununittest.sh testname debuglevel # +banner $1 # put megatest on path from correct location mtbindir=$(readlink -f ../bin) - + export PATH="${mtbindir}:$PATH" # Clean setup # -dbdir=$(cd simplerun;megatest -show-config -section setup -var linktree)/.db -rm -f simplerun/megatest.db simplerun/monitor.db simplerun/db/monitor.db $dbdir/*.db +dbdir=$(echo /tmp/$USER/megatest_localdb/simplerun/.[a-zA-Z]*/) +echo "dbdir=$dbdir" +rm -f simplerun/megatest.db simplerun/monitor.db simplerun/db/monitor.db rm -rf simplelinks/ simpleruns/ simplerun/db/ $dbdir mkdir -p simplelinks simpleruns (cd simplerun;cp ../../*_records.scm .;perl -pi.bak -e 's/define-inline/define/' *_records.scm) (cd simplerun;cp ../../altdb.scm .) Index: tests/simplerun/megatest.config ================================================================== --- tests/simplerun/megatest.config +++ tests/simplerun/megatest.config @@ -1,5 +1,22 @@ +# Copyright 2006-2017, Matthew Welland. +# +# This file is part of Megatest. +# +# Megatest is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# Megatest is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with Megatest. If not, see . + [fields] SYSTEM TEXT RELEASE TEXT [setup] Index: tests/simplerun/runconfigs.config ================================================================== --- tests/simplerun/runconfigs.config +++ tests/simplerun/runconfigs.config @@ -1,5 +1,22 @@ +# Copyright 2006-2017, Matthew Welland. +# +# This file is part of Megatest. +# +# Megatest is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# Megatest is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with Megatest. If not, see . + [default] ALLTESTS see this variable # Your variables here are grouped by targets [SYSTEM/RELEASE] [SYSTEM_val/RELEASE_val] Index: tests/simplerun/test.config ================================================================== --- tests/simplerun/test.config +++ tests/simplerun/test.config @@ -1,5 +1,22 @@ +# Copyright 2006-2017, Matthew Welland. +# +# This file is part of Megatest. +# +# Megatest is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# Megatest is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with Megatest. If not, see . + [section1] 1 ./blah [section2] Index: tests/simplerun/tests/test1/step1.logpro ================================================================== --- tests/simplerun/tests/test1/step1.logpro +++ tests/simplerun/tests/test1/step1.logpro @@ -1,5 +1,22 @@ +;; Copyright 2006-2017, Matthew Welland. +;; +;; This file is part of Megatest. +;; +;; Megatest is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. +;; +;; Megatest is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with Megatest. If not, see . + ;; You should have at least one expect:required. This ensures that your process ran ;; (expect:required in "LogFileBody" > 0 "Put description here" #/put pattern here/) ;; You may need ignores to suppress false error or warning hits from the later expects ;; NOTE: Order is important here! Index: tests/simplerun/tests/test1/step1.sh ================================================================== --- tests/simplerun/tests/test1/step1.sh +++ tests/simplerun/tests/test1/step1.sh @@ -1,5 +1,22 @@ #!/usr/bin/env bash +# Copyright 2006-2017, Matthew Welland. +# +# This file is part of Megatest. +# +# Megatest is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# Megatest is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with Megatest. If not, see . + # Run your step here echo Got here! Index: tests/simplerun/tests/test1/step2.logpro ================================================================== --- tests/simplerun/tests/test1/step2.logpro +++ tests/simplerun/tests/test1/step2.logpro @@ -1,5 +1,22 @@ +;; Copyright 2006-2017, Matthew Welland. +;; +;; This file is part of Megatest. +;; +;; Megatest is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. +;; +;; Megatest is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with Megatest. If not, see . + ;; You should have at least one expect:required. This ensures that your process ran ;; (expect:required in "LogFileBody" > 0 "Put description here" #/put pattern here/) ;; You may need ignores to suppress false error or warning hits from the later expects ;; NOTE: Order is important here! Index: tests/simplerun/tests/test1/step2.sh ================================================================== --- tests/simplerun/tests/test1/step2.sh +++ tests/simplerun/tests/test1/step2.sh @@ -1,6 +1,23 @@ #!/usr/bin/env bash +# Copyright 2006-2017, Matthew Welland. +# +# This file is part of Megatest. +# +# Megatest is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# Megatest is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with Megatest. If not, see . + # Run your step here echo Got here eh! Index: tests/simplerun/tests/test1/testconfig ================================================================== --- tests/simplerun/tests/test1/testconfig +++ tests/simplerun/tests/test1/testconfig @@ -1,5 +1,22 @@ +# Copyright 2006-2017, Matthew Welland. +# +# This file is part of Megatest. +# +# Megatest is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# Megatest is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with Megatest. If not, see . + # Add additional steps here. Format is "stepname script" [ezsteps] step1 step1.sh step2 step2.sh Index: tests/simplerun/tests/test2/step1.logpro ================================================================== --- tests/simplerun/tests/test2/step1.logpro +++ tests/simplerun/tests/test2/step1.logpro @@ -1,5 +1,22 @@ +;; Copyright 2006-2017, Matthew Welland. +;; +;; This file is part of Megatest. +;; +;; Megatest is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. +;; +;; Megatest is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with Megatest. If not, see . + ;; You should have at least one expect:required. This ensures that your process ran ;; (expect:required in "LogFileBody" > 0 "Put description here" #/put pattern here/) ;; You may need ignores to suppress false error or warning hits from the later expects ;; NOTE: Order is important here! Index: tests/simplerun/tests/test2/step1.sh ================================================================== --- tests/simplerun/tests/test2/step1.sh +++ tests/simplerun/tests/test2/step1.sh @@ -1,3 +1,20 @@ #!/usr/bin/env bash +# Copyright 2006-2017, Matthew Welland. +# +# This file is part of Megatest. +# +# Megatest is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# Megatest is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with Megatest. If not, see . + # Run your step here Index: tests/simplerun/tests/test2/step2.logpro ================================================================== --- tests/simplerun/tests/test2/step2.logpro +++ tests/simplerun/tests/test2/step2.logpro @@ -1,5 +1,22 @@ +;; Copyright 2006-2017, Matthew Welland. +;; +;; This file is part of Megatest. +;; +;; Megatest is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. +;; +;; Megatest is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with Megatest. If not, see . + ;; You should have at least one expect:required. This ensures that your process ran ;; (expect:required in "LogFileBody" > 0 "Put description here" #/put pattern here/) ;; You may need ignores to suppress false error or warning hits from the later expects ;; NOTE: Order is important here! Index: tests/simplerun/tests/test2/step2.sh ================================================================== --- tests/simplerun/tests/test2/step2.sh +++ tests/simplerun/tests/test2/step2.sh @@ -1,3 +1,20 @@ #!/usr/bin/env bash +# Copyright 2006-2017, Matthew Welland. +# +# This file is part of Megatest. +# +# Megatest is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# Megatest is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with Megatest. If not, see . + # Run your step here Index: tests/simplerun/tests/test2/testconfig ================================================================== --- tests/simplerun/tests/test2/testconfig +++ tests/simplerun/tests/test2/testconfig @@ -1,5 +1,22 @@ +# Copyright 2006-2017, Matthew Welland. +# +# This file is part of Megatest. +# +# Megatest is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# Megatest is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with Megatest. If not, see . + # Add additional steps here. Format is "stepname script" [ezsteps] step1 step1.sh step2 step2.sh @@ -15,7 +32,7 @@ # test_meta is a section for storing additional data on your test [test_meta] author matt owner matt description Yet another example test -tags tagone,tagtwo +tags tagone,tagtwo,quick reviewed never Index: tests/speedtest/megatest.config ================================================================== --- tests/speedtest/megatest.config +++ tests/speedtest/megatest.config @@ -1,5 +1,22 @@ +# Copyright 2006-2017, Matthew Welland. +# +# This file is part of Megatest. +# +# Megatest is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# Megatest is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with Megatest. If not, see . + [fields] sysname TEXT fsname TEXT datapath TEXT Index: tests/speedtest/runconfigs.config ================================================================== --- tests/speedtest/runconfigs.config +++ tests/speedtest/runconfigs.config @@ -1,3 +1,20 @@ +# Copyright 2006-2017, Matthew Welland. +# +# This file is part of Megatest. +# +# Megatest is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# Megatest is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with Megatest. If not, see . + [default] SOMEVAR This should show up in SOMEVAR3 Index: tests/speedtest/tests/speedtest/main.sh ================================================================== --- tests/speedtest/tests/speedtest/main.sh +++ tests/speedtest/tests/speedtest/main.sh @@ -1,6 +1,22 @@ #!/bin/bash +# Copyright 2006-2017, Matthew Welland. +# +# This file is part of Megatest. +# +# Megatest is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# Megatest is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with Megatest. If not, see . # a bunch of steps in 2 second increments for i in 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17;do $MT_MEGATEST -step step$i :state start :status running -setlog results$i.html sleep $TEST_DELAY Index: tests/speedtest/tests/speedtest/testconfig ================================================================== --- tests/speedtest/tests/speedtest/testconfig +++ tests/speedtest/tests/speedtest/testconfig @@ -1,5 +1,22 @@ +# Copyright 2006-2017, Matthew Welland. +# +# This file is part of Megatest. +# +# Megatest is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# Megatest is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with Megatest. If not, see . + [setup] runscript main.sh [requirements] priority 1 DELETED tests/stats.txt Index: tests/stats.txt ================================================================== --- tests/stats.txt +++ /dev/null @@ -1,77 +0,0 @@ -DB Stats: a1236d6bf92ec5cb8955f490761b21b0d3eea9d3 -======== -Cmd Count TotTime Avg -get-count-tests-running-for-run-id 1035 237.0 0.23 -get-count-tests-running-in-jobgroup 884 119.0 0.13 -get-count-tests-running 884 169.0 0.19 -get-prereqs-not-met 884 732.0 0.83 -get-test-info-by-id 673 122.0 0.18 -get-keys 476 1.0 0.00 -get-test-id 356 42.0 0.12 -testmeta-get-record 203 24.0 0.12 -roll-up-pass-fail-counts 159 39.0 0.25 -register-test 140 30.0 0.21 -test-set-rundir-shortdir 128 98.0 0.77 -test-set-status-state 94 45.0 0.48 -find-and-mark-incomplete 32 0.0 0.00 -state-status-msg 25 4.0 0.16 -delete-tests-in-state 12 4.0 0.33 -get-tests-for-run-mindata 8 0.0 0.00 -get-all-run-ids 5 2.0 0.40 -get-run-info 4 0.0 0.00 -register-run 4 5.0 1.25 -set-tests-state-status 4 15.0 3.75 -get-tests-for-run 4 15.0 3.75 - -# After converting first three functions above to sqlite3:first-result -DB Stats -======== -Cmd Count TotTime Avg -get-count-tests-running-for-run-id 1138 179.0 0.16 -get-count-tests-running-in-jobgroup 987 91.0 0.09 -get-count-tests-running 987 171.0 0.17 -get-prereqs-not-met 987 892.0 0.90 -get-test-info-by-id 672 95.0 0.14 -get-keys 476 0.0 0.00 -get-test-id 355 41.0 0.12 -testmeta-get-record 203 15.0 0.07 -roll-up-pass-fail-counts 159 30.0 0.19 -register-test 140 22.0 0.16 -test-set-rundir-shortdir 128 855.0 6.68 -test-set-status-state 94 20.0 0.21 -find-and-mark-incomplete 36 1.0 0.03 -state-status-msg 24 5.0 0.21 -delete-tests-in-state 12 2.0 0.17 -get-tests-for-run-mindata 9 0.0 0.00 -get-all-run-ids 5 1.0 0.20 -register-run 4 1.0 0.25 -get-tests-for-run 4 11.0 2.75 -get-run-info 4 0.0 0.00 -set-tests-state-status 4 17.0 4.25 - -DB Stats another run, converted one or two non-relevant functions to sqlite3:first-result -======== -Cmd Count TotTime Avg -get-count-tests-running-for-run-id 987 157.0 0.16 -get-count-tests-running-in-jobgroup 836 79.0 0.09 -get-count-tests-running 836 121.0 0.14 -get-prereqs-not-met 836 513.0 0.61 -get-test-info-by-id 673 85.0 0.13 -get-keys 476 0.0 0.00 -get-test-id 356 32.0 0.09 -testmeta-get-record 203 19.0 0.09 -roll-up-pass-fail-counts 159 27.0 0.17 -register-test 140 23.0 0.16 -test-set-rundir-shortdir 128 35.0 0.27 -test-set-status-state 94 20.0 0.21 -find-and-mark-incomplete 40 0.0 0.00 -state-status-msg 25 5.0 0.20 -delete-tests-in-state 12 1.0 0.08 -get-tests-for-run-mindata 10 0.0 0.00 -get-all-run-ids 5 0.0 0.00 -set-tests-state-status 4 15.0 3.75 -register-run 4 2.0 0.50 -get-run-info 4 1.0 0.25 -get-tests-for-run 4 12.0 3.00 - - Index: tests/supportfiles/ruby/librunscript.rb ================================================================== --- tests/supportfiles/ruby/librunscript.rb +++ tests/supportfiles/ruby/librunscript.rb @@ -1,5 +1,22 @@ +# Copyright 2006-2017, Matthew Welland. +# +# This file is part of Megatest. +# +# Megatest is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# Megatest is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with Megatest. If not, see . + # This is the library of stuff for megatest def run_and_record(stepname, cmd, checks) system "megatest -step #{stepname} :state start :status n/a" system cmd Index: tests/test7.logpro ================================================================== --- tests/test7.logpro +++ tests/test7.logpro @@ -1,5 +1,22 @@ +;; Copyright 2006-2017, Matthew Welland. +;; +;; This file is part of Megatest. +;; +;; Megatest is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. +;; +;; Megatest is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with Megatest. If not, see . + ;; You should have at least one expect:required. This ensures that your process ran (expect:required in "LogFileBody" > 0 "All tests launched" #/INFO:.*All tests launched/) ;; You may need ignores to suppress false error or warning hits from the later expects ;; NOTE: Order is important here! Index: tests/tests.scm ================================================================== --- tests/tests.scm +++ tests/tests.scm @@ -1,14 +1,22 @@ ;; Copyright 2006-2012, Matthew Welland. ;; -;; This program is made available under the GNU GPL version 2.0 or -;; greater. See the accompanying file COPYING for details. +;; This file is part of Megatest. +;; +;; Megatest is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. +;; +;; Megatest is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. ;; -;; This program is distributed WITHOUT ANY WARRANTY; without even the -;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR -;; PURPOSE. - +;; You should have received a copy of the GNU General Public License +;; along with Megatest. If not, see . +;; ;; strftime('%m/%d/%Y %H:%M:%S','now','localtime') (require-extension test) (require-extension regex) (require-extension srfi-18) @@ -17,10 +25,26 @@ (import srfi-18) ;; (require-extension zmq) ;; (import zmq) (define test-work-dir (current-directory)) + +;; given list of lists +;; ( ( msg expected param1 param2 ...) +;; ( ... ) ) +;; apply test to all +;; +(define (test-batch proc pname inlst #!key (post-proc #f)) + (for-each + (lambda (spec) + (let ((msg (conc pname " " (car spec))) + (result (cadr spec)) + (params (cddr spec))) + (if post-proc + (test msg result (post-proc (apply proc params))) + (test msg result (apply proc params))))) + inlst)) ;; read in all the _record files (let ((files (glob "*_records.scm"))) (for-each (lambda (file) @@ -32,11 +56,11 @@ (fname (conc "../unittests/" unit-test-name ".scm"))) (if (file-exists? fname) (load fname) (print "ERROR: Unit test " unit-test-name " not found in unittests directory"))) - - (list "abc" "abc/%" "ab%/c%" "~abc/c%" "abc/~c%" "a,b/c,%/d" "%/,%/a" "%/,%/a" "%/,%/a" "%" "%" "%/" "%/" "%abc%") - (list "abc" "abc" "abcd" "abc" "abc" "a" "abc" "def" "ghi" "a" "a" "a" "a" "abc") - (list "" "" "cde" "cde" "cde" "" "" "a" "b" "" "b" "" "b" "abc") - (list #t #t #t #f #f #t #t #t #f #t #t #t #f #t)) +;;; huh? why is this here? +;; (list "abc" "abc/%" "ab%/c%" "~abc/c%" "abc/~c%" "a,b/c,%/d" "%/,%/a" "%/,%/a" "%/,%/a" "%" "%" "%/" "%/" "%abc%") +;; (list "abc" "abc" "abcd" "abc" "abc" "a" "abc" "def" "ghi" "a" "a" "a" "a" "abc") +;; (list "" "" "cde" "cde" "cde" "" "" "a" "b" "" "b" "" "b" "abc") +;; (list #t #t #t #f #f #t #t #t #f #t #t #t #f #t) Index: tests/unit.logpro ================================================================== --- tests/unit.logpro +++ tests/unit.logpro @@ -1,5 +1,22 @@ +;; Copyright 2006-2017, Matthew Welland. +;; +;; This file is part of Megatest. +;; +;; Megatest is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. +;; +;; Megatest is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with Megatest. If not, see . + ;; Ignore initial errors (trigger "ScriptStart" #/^Script started/) (trigger "TestStart" #/^megatest> \(/) (section "startup" "ScriptStart" "TestStart") ADDED tests/unittests/all-api.scm Index: tests/unittests/all-api.scm ================================================================== --- /dev/null +++ tests/unittests/all-api.scm @@ -0,0 +1,180 @@ + +;;====================================================================== +;; A L L - A P I +;;====================================================================== + +;; Copyright 2006-2017, Matthew Welland. +;; +;; This file is part of Megatest. +;; +;; Megatest is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. +;; +;; Megatest is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with Megatest. If not, see . + + +;; Run like this: +;; +;; Update the following line. make unit from parent directory. +;; ./rununittest.sh all-api 1 + +;; Definitions: +;; NTN - no test needed +;; DEP - function is deprecated, no point in testing +;; NED - function nested under others, no test needed. +;; DEF - deferred + + +;; Issues: +;; 1. Most of the API calls accept a string or symbol for the function name, but at least one requires a symbol. +;; Should we decide one way or the other, symbol or string, (seems symbol is best) and enforce that in the API? Current code: +;; (cmd (if (symbol? cmd-in) +;; cmd-in +;; (string->symbol cmd-in))) +;; Just accept symbol +;; In the refactor, change execute-requests to only accept a symbol. + +;; 2. Some functions return in element 1 of the vector. What to do about this? Fix them to return a measurable value? +;; Or is there a way to make test accept ? - No. +;; This is why I had to use vector-ref and look at one value or the other. +;; Look at why functions are returning unspecified. +;; The last function they call returns nothing. + +;; 3. Some API functions call non-existent db functions. +;; Delete these API functions after checking that they are not called? +;; Comment them out and give a date to delete. (in the refactor branch?) + +;; 4. get-tests-times: no such query supported in api.scm, but it is in the list of read-only queries. Remove it? Or implement it if it's in db.scm? + + +(define my-dbstruct (db:setup #t)) +(define toppath (current-directory)) +(define keypatts '(("SYSTEM" "ubuntu")("RELEASE" "v1.234")) ) +(define keys (db:get-keys my-dbstruct)) + +(test #f #t (vector-ref (api:execute-requests my-dbstruct (vector 'start-server (list *toppath* ))) 0)) +(test #f '() (vector-ref (api:execute-requests my-dbstruct (vector 'get-key-val-pairs (list 0 ))) 1)) +(test #f #t (vector-ref (api:execute-requests my-dbstruct (vector 'set-var (list "LAST_UPDATE" 1234567))) 0)) +(test #f 1234567 (vector-ref (api:execute-requests my-dbstruct (vector 'get-var (list "LAST_UPDATE" ))) 1)) +(test #f #t (vector-ref (api:execute-requests my-dbstruct (vector 'del-var (list "LAST_UPDATE" ))) 0)) +(test #f '("SYSTEM" "RELEASE") (vector-ref (api:execute-requests my-dbstruct (vector 'get-keys (list ))) 1)) +(test #f '() (vector-ref (api:execute-requests my-dbstruct (vector 'get-key-vals (list 1 ))) 1)) +(test #f 0 (vector-ref (api:execute-requests my-dbstruct (vector 'test-toplevel-num-items (list 1 "foo"))) 1)) +(test #f #t (vector-ref (api:execute-requests my-dbstruct (vector 'get-test-info-by-id (list 1 1))) 0)) +(test #f #t (vector-ref (api:execute-requests my-dbstruct (vector 'get-steps-info-by-id (list 1))) 0)) +(test #f #t (vector-ref (api:execute-requests my-dbstruct (vector 'get-data-info-by-id (list 1))) 0)) +(test #f '(#t "successful login") (vector-ref (api:execute-requests my-dbstruct (vector 'login (list toppath megatest-version "Fred"))) 1)) +(test #f '(-1 . 0) (vector-ref (api:execute-requests my-dbstruct (vector 'get-latest-host-load (list "localhost"))) 1)) +(test #f #t (vector-ref (api:execute-requests my-dbstruct (vector 'get-changed-record-ids (list 0))) 0)) +(test #f #t (vector-ref (api:execute-requests my-dbstruct (vector 'get-run-record-ids (list "%" 1 keys "%/%"))) 0)) +(test #f #t (vector-ref (api:execute-requests my-dbstruct (vector 'get-not-completed-cnt (list 1))) 0)) +(test #f #t (vector-ref (api:execute-requests my-dbstruct (vector 'get-tests-tags (list ))) 0)) +(test #f '("SYSTEM" "RELEASE") (vector-ref (api:execute-requests my-dbstruct (vector 'get-keys-write (list ))) 1)) +(test #f (vector '("SYSTEM" "RELEASE") '())(vector-ref (api:execute-requests my-dbstruct (vector 'get-targets (list 1 ))) 1)) +(test #f "" (vector-ref (api:execute-requests my-dbstruct (vector 'get-target (list 1 ))) 1)) +(test #f #t (vector-ref (api:execute-requests my-dbstruct (vector 'general-call (list 'register-test 1 1 "foo" ""))) 0)) +(test #f 1 (vector-ref (api:execute-requests my-dbstruct (vector 'get-test-id (list 1 "foo" ""))) 1)) +(test #f "/tmp/badname" (vector-ref (api:execute-requests my-dbstruct (vector 'test-get-rundir-from-test-id (list 1 1))) 1)) +(test #f #t (vector-ref (api:execute-requests my-dbstruct (vector 'set-tests-state-status (list 1 '("foo") "COMPLETED" "PASS" "NOT_STARTED" "PASS"))) 0)) +(test #f #t (vector-ref (api:execute-requests my-dbstruct (vector 'test-set-state-status-by-id (list 1 1 "COMPLETED" "PASS" "Just testing!"))) 0)) +(test #f #t (vector-ref (api:execute-requests my-dbstruct (vector 'get-tests-for-run (list 1 "%" '() '() #f #f #f #f #f #f 0 #f))) 0)) +(test #f #t (vector-ref (api:execute-requests my-dbstruct (vector 'get-tests-for-run-mindata (list 1 "%" '("COMPLETED") '("PASS") #f ))) 0)) +(test #f #t (vector-ref (api:execute-requests my-dbstruct (vector 'delete-test-records (list 1 2 ))) 0)) +(test #f #t (vector-ref (api:execute-requests my-dbstruct (vector 'test-set-state-status (list 1 1 "COMPLETED" "FAIL" "Another message" ))) 0)) +(test #f '() (vector-ref (api:execute-requests my-dbstruct (vector 'get-matching-previous-test-run-records (list 1 "foo" ""))) 1)) +(test #f '("/tmp/badname" "logs/final.log") (vector-ref (api:execute-requests my-dbstruct (vector 'test-get-logfile-info (list 1 "foo"))) 1)) +(test #f #t (vector-ref (api:execute-requests my-dbstruct (vector 'test-get-records-for-index-file (list 1 "foo"))) 0)) +(test #f #t (vector-ref (api:execute-requests my-dbstruct (vector 'get-testinfo-state-status (list 1 1))) 0)) +(test #f #t (vector-ref (api:execute-requests my-dbstruct (vector 'general-call (list 'test-set-log 1 "/tmp/another/logfile/eh" 1))) 0)) +(test #f #t (vector-ref (api:execute-requests my-dbstruct (vector 'test-set-archive-block-id (list 1 1 123))) 0)) +(test #f #t (vector-ref (api:execute-requests my-dbstruct (vector 'test-set-top-process-pid (list 1 1 123))) 0)) +(test #f 123 (vector-ref (api:execute-requests my-dbstruct (vector 'test-get-top-process-pid (list 1 1))) 1)) +(test #f #t (vector-ref (api:execute-requests my-dbstruct (vector 'get-run-ids-matching-target (list keys "%/%" #f "%" "%" "%" "%"))) 0)) +(test #f #t (vector-ref (api:execute-requests my-dbstruct (vector 'test-get-paths-matching-keynames-target-new (list 1 keys "%/%" #f "%" "%" "%" "%"))) 0)) +(test #f '() (vector-ref (api:execute-requests my-dbstruct (vector 'get-prereqs-not-met (list 1 '() "foo" "" '(normal) '()))) 1)) +(test #f 0 (vector-ref (api:execute-requests my-dbstruct (vector 'get-count-tests-running-for-run-id (list 1))) 1)) +(test #f 0 (vector-ref (api:execute-requests my-dbstruct (vector 'get-count-tests-running (list 1))) 1)) +(test #f 0 (vector-ref (api:execute-requests my-dbstruct (vector 'get-count-tests-running-for-testname (list 1 "foo"))) 1)) +(test #f 0 (vector-ref (api:execute-requests my-dbstruct (vector 'get-count-tests-running-in-jobgroup (list 1 "nada"))) 1)) +(test #f #t (vector-ref (api:execute-requests my-dbstruct (vector 'set-state-status-and-roll-up-items (list 1 "foo" "" "COMPLETED" "FAIL" "Just yet another message"))) 0)) +(test #f #t (vector-ref (api:execute-requests my-dbstruct (vector 'set-state-status-and-roll-up-run (list 1 "COMPLETED" "FAIL"))) 0)) +(test #f #t (vector-ref (api:execute-requests my-dbstruct (vector 'top-test-set-per-pf-counts (list 1 "foo"))) 0)) +(test #f #t (vector-ref (api:execute-requests my-dbstruct (vector 'get-raw-run-stats (list 1))) 0)) +(test #f #t (vector-ref (api:execute-requests my-dbstruct (vector 'get-run-info (list 1))) 0)) +(test #f 0 (vector-ref (api:execute-requests my-dbstruct (vector 'get-num-runs (list "%"))) 1)) +(test #f 0 (vector-ref (api:execute-requests my-dbstruct (vector 'get-runs-cnt-by-patt (list "%" "%/%" keys))) 1)) +(test #f #t (vector-ref (api:execute-requests my-dbstruct (vector 'register-run (list '(("SYSTEM" "ubuntu")("RELEASE" "v1.234")) "bar" "NEW" "JUSTFINE" "bobafett" "quick" ))) 0)) +(test #f #(#t "bar") (api:execute-requests my-dbstruct (vector 'get-run-name-from-id '(1)))) +(test #f #t (vector-ref (api:execute-requests my-dbstruct (vector 'delete-run (list 2))) 0)) ;; delete a non-existant run +(test #f #t (vector-ref (api:execute-requests my-dbstruct (vector 'update-run-stats (list 1 '()))) 0)) +(test #f #t (vector-ref (api:execute-requests my-dbstruct (vector 'get-main-run-stats (list 1 ))) 0)) +(test #f #t (vector-ref (api:execute-requests my-dbstruct (vector 'delete-old-deleted-test-records '())) 0)) +(test #f #t (vector-ref (api:execute-requests my-dbstruct (vector 'get-runs (list "%" 10 0 keypatts))) 0)) +(test #f #t (vector-ref (api:execute-requests my-dbstruct (vector 'simple-get-runs (list "%" 10 0 keypatts 0))) 0)) +(test #f #(#t (1))(api:execute-requests my-dbstruct (vector 'get-all-run-ids '()))) +(test #f #(#t ()) (api:execute-requests my-dbstruct (vector 'get-prev-run-ids '(1)))) +(test #f #(#t "JUSTFINE") (api:execute-requests my-dbstruct (vector 'get-run-status '(1)))) +(test #f #(#t "NEW") (api:execute-requests my-dbstruct (vector 'get-run-state '(1)))) +(test #f #(#t (("Totals" "UNKNOWN" 1) ("bar" "UNKNOWN" 1))) (api:execute-requests my-dbstruct (vector 'get-run-stats '()))) +(test #f #(#t ()) (api:execute-requests my-dbstruct (vector 'get-run-times '(1 1 )))) +(test #f #t (vector-ref (api:execute-requests my-dbstruct (vector 'lock/unlock-run '(1 #t #f "mikey"))) 0)) +(test #f #t (vector-ref (api:execute-requests my-dbstruct (vector 'set-run-status '(1 "NOTFINE" "A message"))) 0)) +(test #f #t (vector-ref (api:execute-requests my-dbstruct (vector 'set-run-state-status '(1 "NOTFINE" "AMESS"))) 0)) +(test #f #t (vector-ref (api:execute-requests my-dbstruct (vector 'update-run-event_time '(1))) 0)) +(test #f #t (vector-ref (api:execute-requests my-dbstruct (vector 'get-runs-by-patt (list keys "%" "%/%" #f #f #f #f "ASC"))) 0)) +(test #f #t (vector-ref (api:execute-requests my-dbstruct (vector 'get-steps-data (list 1 1))) 0)) +(test #f #t (vector-ref (api:execute-requests my-dbstruct (vector 'get-steps-for-test (list 1 1))) 0)) +(test #f #t (vector-ref (api:execute-requests my-dbstruct (vector 'delete-steps-for-test! (list 1 1))) 0)) +(test #f #t (vector-ref (api:execute-requests my-dbstruct (vector 'teststep-set-status! (list 1 1 "step1" "COMPLETED" "PASS" "force pass" "/tmp/logfile"))) 0)) +(test #f #t (vector-ref (api:execute-requests my-dbstruct (vector 'test-data-rollup (list 1 1 "COMPLETED"))) 0)) +(test #f #t (vector-ref (api:execute-requests my-dbstruct (vector 'csv->test-data (list 1 1 "some,data"))) 0)) +(test #f #t (vector-ref (api:execute-requests my-dbstruct (vector 'read-test-data (list 1 1 "%"))) 0)) +(test #f #t (vector-ref (api:execute-requests my-dbstruct (vector 'read-test-data* (list 1 1 "%" "%"))) 0)) +(test #f #t (vector-ref (api:execute-requests my-dbstruct (vector 'tasks-add (list "run" "Fred" "%" "foo" "%/%" #f))) 0)) +(test #f #t (vector-ref (api:execute-requests my-dbstruct (vector 'tasks-set-state-given-param-key (list "mykey" "COMPLETED"))) 0)) +(test #f #t (vector-ref (api:execute-requests my-dbstruct (vector 'tasks-get-last (list "%" "foo"))) 0)) +(test #f #t (vector-ref (api:execute-requests my-dbstruct (vector 'find-task-queue-records (list "%" "myrun" "%/%" "RUNNING" "run"))) 0)) +(test #f #t (vector-ref (api:execute-requests my-dbstruct (vector 'testmeta-add-record (list "foo"))) 0)) +(test #f #t (vector-ref (api:execute-requests my-dbstruct (vector 'testmeta-update-field (list "foo" "description" "junk"))) 0)) +(test #f #t (vector-ref (api:execute-requests my-dbstruct (vector 'testmeta-get-record (list "foo"))) 0)) +(test #f #t (vector-ref (api:execute-requests my-dbstruct (vector 'have-incompletes? (list 1 12000))) 0)) +(test #f #t (vector-ref (api:execute-requests my-dbstruct (vector 'mark-incomplete (list 1 12000))) 0)) +(test #f #t (vector-ref (api:execute-requests my-dbstruct (vector 'no-sync-set (list "field1" "value1"))) 0)) +(test #f "value1" (vector-ref (api:execute-requests my-dbstruct (vector 'no-sync-get/default (list "field1" #f))) 1)) +(test #f #t (vector-ref (api:execute-requests my-dbstruct (vector 'no-sync-del! (list "field1"))) 0)) +(test #f #t (vector-ref (api:execute-requests my-dbstruct (vector 'no-sync-get-lock (list "mykey"))) 0)) +(test #f 1 (vector-ref (api:execute-requests my-dbstruct (vector 'archive-register-disk (list "mydisk" "/usr/mydisk" 10000000))) 1)) +(test #f #t (vector-ref (api:execute-requests my-dbstruct (vector 'archive-register-block-name (list 1 "/usr/mydisk/myblock"))) 0)) +(test #f #t (vector-ref (api:execute-requests my-dbstruct (vector 'test-get-archive-block-info (list 1 ))) 0)) +(test #f #t (vector-ref (api:execute-requests my-dbstruct (vector 'ping (list ))) 0)) +(test #f #t (vector-ref (api:execute-requests my-dbstruct (vector 'kill-server (list ))) 0)) + +;; api.scm calls db:get-previous-test-run-record, which does not exist. +;;(test #f '() (vector-ref (api:execute-requests my-dbstruct (vector "get-previous-test-run-record" (list 1 ))) 1)) + +;; no such query supported in api.scm, but it is is the list of read-only queries. +;;(test #f #t (vector-ref (api:execute-requests my-dbstruct (vector 'get-tests-times (list ))) 0)) + +;; api.scm calls db:get-tests-for-runs-mindata, which does not exist. +;;(test #f #t (vector-ref (api:execute-requests my-dbstruct (vector 'get-tests-for-runs-mindata (list 1 "%" '("COMPLETED") '("PASS") #f ))) 0)) + +;;This api function calls db:archive-allocate-testsuite/area-to-block, which does not exist. +;;(test #f #t (vector-ref (api:execute-requests my-dbstruct (vector 'archive-allocate-testsuite/area-to-block (list 1 "/usr/mydisk/myblock"))) 0)) + +;;debug this: ERROR: parameter last-update for db:sync-tables must be a pair or a number, received: (0 . last_update) +;;(test #f #t (vector-ref (api:execute-requests my-dbstruct (vector 'sync-inmem->db (list 1))) 0)) + +;;debug this. Error: bad argument count - received 0 but expected 5: #. + + +;; Run like this: +;; +;; ./rununittest.sh all-rmt 1 + +;; Definitions: +;; NTN - no test needed +;; DEP - function is deprecated, no point in testing +;; NED - function nested under others, no test needed. +;; DEF - deferred + +(print "start dir: " (current-directory)) + +(define toppath (current-directory)) + +(test #f #f (server:check-if-running toppath)) ;; these are used by server:start-and-wait +(test #f #t (list? (server:get-list toppath))) +(test #f '() (server:get-best '())) +(test #f #t (common:simple-file-lock-and-wait "test.lock" expire-time: 15)) +(test #f "test.lock" (common:simple-file-release-lock "test.lock")) +(test #f #t (string? (server:get-best-guess-address (get-host-name)))) +(test #f #t (string? (car (common:get-homehost)))) + +;; clean out any old running servers +;; +(let ((servers (server:get-list toppath))) + (print "Known servers: " servers) + (if (not (null? servers)) + (begin + (for-each + (lambda (server) + (let ((pid (list-ref server 4))) + (thread-start! + (make-thread + (lambda () + (print "Attempting to kill server: " server) + (print "Attempting to kill pid " pid) + (system (conc "kill " pid)) + (thread-sleep! 2) + (system (conc "kill -9 " pid))) + (conc pid))))) + servers) + (thread-sleep! 2)))) +;; let's start up a server the mechanical way +(system "nbfake megatest -server -") +(thread-sleep! 2) +;; (test #f #t (string? (server:start-and-wait *toppath*))) + +(test "setup for run" #t (begin (launch:setup) + (string? (getenv "MT_RUN_AREA_HOME")))) +(test #f #t (vector? (client:setup-http toppath))) +(test #f #t (vector? (client:setup toppath))) + +(test #f #t (vector? (rmt:get-connection-info toppath))) ;; TODO: push areapath down. +(test #f #t (string? (server:check-if-running "."))) +;; DEF (test #f #f (rmt:send-receive-no-auto-client-setup *runremote* 'get-keys #f '())) +;; DEF (rmt:kill-server run-id) +;; DEF (rmt:start-server run-id) +(test #f '(#t "successful login")(rmt:login #f)) +;; DEF (rmt:login-no-auto-client-setup connection-info) +(test #f #t (pair? (rmt:get-latest-host-load (get-host-name)))) + +;; get-latest-host-load does a lookup in the db, it won't return a useful value unless +;; a test ran recently on host +(test-batch rmt:get-latest-host-load + "rmt:get-latest-host-load" + (list (list "localhost" #t (get-host-name)) + (list "not-a-host" #t "not-a-host" )) + post-proc: pair?) + +(test #f #t (list? (rmt:get-changed-record-ids 0))) + +(test #f #f (begin (runs:update-all-test_meta #f) #f)) + +(test #f '("test1" "test2")(sort (alist-ref "tagtwo" (rmt:get-tests-tags) equal?) string<=)) +(test #f '() (rmt:get-key-val-pairs 0)) +(test #f '("SYSTEM" "RELEASE") (rmt:get-keys)) +(test #f '("SYSTEM" "RELEASE") (rmt:get-keys-write)) ;; dummy query to force server start +(test #f '() (rmt:get-key-vals 1)) +(test #f (vector '("SYSTEM" "RELEASE") '()) (rmt:get-targets)) +(test #f "" (rmt:get-target 1)) +(test #f #t (rmt:register-test 1 "foo" "")) +(test #f 1 (rmt:get-test-id 1 "foo" "")) +(test #f "foo" (vector-ref (rmt:get-test-info-by-id 1 1) 2)) +(test #f "/tmp/badname" (rmt:test-get-rundir-from-test-id 1 1)) +;; (test #f '(1) (db:set-tests-state-status *db* 1 '("foo") "COMPLETED" "PASS" "NOT_STARTED" "PASS")) ;; trust that this was tested in all-api +(test #f '(1) (rmt:set-tests-state-status 1 '("foo") "COMPLETED" "PASS" "NOT_STARTED" "PASS")) +(test #f #t (mt:test-set-state-status-by-id 1 1 "COMPLETED" "PASS" "Just testing!")) +(test #f #t (list? (rmt:get-tests-for-run 1 "%" '() '() #f #f #f #f #f #f 0 #f))) +(test #f #t (list? (rmt:get-tests-for-runs-mindata '(1) "%" '() '() #f))) +(test #f #f (begin (rmt:delete-test-records 1 2) #f)) +(test #f #t (begin (rmt:test-set-state-status 1 1 "COMPLETED" "FAIL" "Another message") #t)) +(test #f 0 (rmt:test-toplevel-num-items 1 "foo")) +(test #f '()(rmt:get-matching-previous-test-run-records 1 "foo" "")) +(test #f '("/tmp/badname" "logs/final.log") (rmt:test-get-logfile-info 1 "foo")) +(test #f '()(rmt:test-get-records-for-index-file 1 "foo")) +(test #f #t (vector? (rmt:get-testinfo-state-status 1 1))) +(test #f #t (rmt:test-set-log! 1 1 "/tmp/another/logfile/eh")) +(test #f #f (begin (rmt:test-set-top-process-pid 1 1 123) #f)) +(test #f 123 (rmt:test-get-top-process-pid 1 1)) +(define keys (rmt:get-keys)) +(test #f '()(rmt:get-run-ids-matching-target keys "%/%" #f "%" "%" "%" "%")) +(test #f '()(rmt:test-get-paths-matching-keynames-target-new keys "%/%" #f "%" "%" "%" "%")) +(test #f '()(rmt:get-prereqs-not-met 1 '() "foo" "")) +(test #f 0 (rmt:get-count-tests-running-for-run-id 1)) +(test #f 0 (rmt:get-count-tests-running 1)) +(test #f 0 (rmt:get-count-tests-running-for-testname 1 "foo")) +(test #f 0 (rmt:get-count-tests-running-in-jobgroup 1 "nada")) +(test #f #f (begin (rmt:set-state-status-and-roll-up-items 1 "foo" "" "COMPLETED" "FAIL" "Just yet another message") #f)) +(test #f #t (rmt:top-test-set-per-pf-counts 1 "foo")) +(test #f '() (rmt:get-raw-run-stats 1)) +(test #f #t (vector? (rmt:get-run-info 1))) +(test #f 0 (rmt:get-num-runs "%")) +(define keypatts '(("SYSTEM" "ubuntu")("RELEASE" "v1.234")) ) +(test #f 1 (rmt:register-run '(("SYSTEM" "ubuntu")("RELEASE" "v1.234")) "bar" "NEW" "JUSTFINE" "bobafett" "quick")) +(test #f "bar" (rmt:get-run-name-from-id 1)) +(test #f #t (begin (rmt:delete-run 2) #t)) ;; delete a non-existant run +(test #f #t (begin (rmt:update-run-stats 1 '()) #t)) +(test #f #t (begin (rmt:delete-old-deleted-test-records) #t)) +(test #f #t (vector? (rmt:get-runs "%" 10 0 keypatts))) +(test #f '(1)(rmt:get-all-run-ids)) +(test #f '()(rmt:get-prev-run-ids 1)) +(test #f #t (begin (rmt:lock/unlock-run 1 #t #f "mikey") #t)) +(test #f "JUSTFINE" (rmt:get-run-status 1)) +(test #f #t (begin (rmt:set-run-status 1 "NOTFINE" msg: "A message") #t)) +(test #f #t (begin (rmt:update-run-event_time 1) #t)) + +;; (rmt:get-runs-by-patt keys runnamepatt targpatt offset limit fields last-runs-update) ;; fields of #f uses default +;; +(let ((keys (rmt:get-keys)) + (rnp "%") ;; run name patt + (tpt "%/%")) ;; target patt + (test-batch rmt:get-runs-by-patt + "rmt:get-runs-by-patt" + (list (list "t=0" #t keys rnp tpt #f #f #f 0) + (list "t=current" #f keys rnp tpt #f #f #f (+ 100 (current-seconds))) ;; should be no records from the future + ) + post-proc: (lambda (res) + ;; (print "rmt:get-runs-by-patt returned: " res) + (and (vector? res) + (let ((rows (vector-ref res 1))) + (> (length rows) 0)))))) + + +(test #f '(("Totals" "UNKNOWN" 1) ("bar" "UNKNOWN" 1)) (begin (rmt:get-run-stats))) +(test #f #t (begin (rmt:set-run-state-status 1 "COMPLETE" "PASS") #t)) +(test #f '"COMPLETE" (rmt:get-run-state 1)) +(test #f '"PASS" (rmt:get-run-status 1)) +(test #f #t (begin (rmt:set-var "foo" "bar")#t)) +(test #f "bar" (rmt:get-var "foo")) +(test #f #t (begin (rmt:print-db-stats) #t)) +(test #f #t (begin (rmt:del-var "foo") #t)) +(test #f #f (rmt:get-var "foo")) +(test #f (vector #f #f #f #f #f #f #f #f #f #f #f #f) (rmt:get-data-info-by-id 1)) +(test #f '() (rmt:get-key-vals 1)) +(test #f "ubuntu/v1.234" (rmt:get-target 1)) +(print (rmt:get-run-info 1)) +(test #f '((runs) (tests) (test_steps) (test_data)) (rmt:get-run-record-ids "ubuntu/v1.234" 1 '("fail_count") "bar")) +;; (rmt:find-and-mark-incomplete run-id ovr-deadtime) +;; (rmt:get-main-run-stats run-id) +;; (rmt:get-var varname) +;; (rmt:set-var varname value) +;; (rmt:find-and-mark-incomplete-all-runs #!key (ovr-deadtime #f)) +;; (rmt:get-previous-test-run-record run-id test-name item-path) +;; (rmt:get-run-stats) +;; (rmt:teststep-set-status! run-id test-id teststep-name state-in status-in comment logfile) +;; (rmt:get-steps-for-test run-id test-id) +;; (rmt:read-test-data run-id test-id categorypatt #!key (work-area #f)) +;; (rmt:testmeta-add-record testname) +;; (rmt:testmeta-get-record testname) +;; (rmt:testmeta-update-field test-name fld val) +;; (rmt:test-data-rollup run-id test-id status) +;; (rmt:csv->test-data run-id test-id csvdata) +;; (rmt:tasks-find-task-queue-records target run-name test-patt state-patt action-patt) +;; (rmt:tasks-add action owner target runname testpatt params) +;; (rmt:tasks-set-state-given-param-key param-key new-state) +;; (rmt:tasks-get-last target runname) +;; (rmt:archive-get-allocations testname itempath dneeded) +;; (rmt:archive-register-block-name bdisk-id archive-path) +;; (rmt:archive-allocate-testsuite/area-to-block block-id testsuite-name areakey) +;; (rmt:archive-register-disk bdisk-name bdisk-path df) +;; (rmt:test-set-archive-block-id run-id test-id archive-block-id) +;; (rmt:test-get-archive-block-info archive-block-id) +;; NED (rmt:open-qry-close-locally cmd run-id params #!key (remretries 5)) +;; NED (rmt:send-receive cmd rid params #!key (attemptnum 1)(area-dat #f)) ;; start attemptnum at 1 so the modulo below works as expected +;; DEF (test #f #f (rmt:print-db-stats)) +;; DEF (rmt:get-max-query-average run-id) +;; NED (rmt:general-call stmtname run-id . params) +;; DEP (rmt:sdb-qry qry val run-id) +;; DEF (rmt:runtests user run-id testpatt params) +;; DEP (rmt:open-test-db-by-test-id run-id test-id #!key (work-area #f)) +;; DEP (rmt:synchash-get run-id proc synckey keynum params) +;; DEP (test #f #f (rmt:update-pass-fail-counts 1 "foo")) Index: tests/unittests/basicserver.scm ================================================================== --- tests/unittests/basicserver.scm +++ tests/unittests/basicserver.scm @@ -1,8 +1,24 @@ ;;====================================================================== ;; S E R V E R ;;====================================================================== +;; Copyright 2006-2017, Matthew Welland. +;; +;; This file is part of Megatest. +;; +;; Megatest is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. +;; +;; Megatest is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with Megatest. If not, see . ;; Run like this: ;; ;; ./rununittest.sh server 1;(cd simplerun;megatest -stop-server 0) @@ -10,19 +26,83 @@ (define run-id 1) (test "setup for run" #t (begin (launch:setup) (string? (getenv "MT_RUN_AREA_HOME")))) -;; NON Server tests go here - -(test #f #f (db:dbdat-get-path *db*)) -(test #f #f (db:get-run-name-from-id *db* run-id)) -;; (test #f '("SYSTEM" "RELEASE") (rmt:get-keys)) - -;; (exit) - -;; Server tests go here +(test #f #t (and (server:kind-run *toppath*) #t)) + + +(define user (current-user-name)) +(define runname "mytestrun") +(define keys (rmt:get-keys)) +(define runinfo #f) +(define keyvals '(("SYSTEM" "abc")("RELEASE" "def"))) +(define header (list "SYSTEM" "RELEASE" "id" "runname" "state" "status" "owner" "event_time")) + +;; Setup +;; +;; (test #f #f (not (client:setup run-id))) +;; (test #f #f (not (hash-table-ref/default *runremote* run-id #f))) + +;; Login +;; +(test #f'(#t "successful login") + (rmt:login run-id)) + +;; Keys +;; +(test #f '("SYSTEM" "RELEASE") (rmt:get-keys)) + +;; No data in db +;; +(test #f '() (rmt:get-all-run-ids)) +(test #f #f (rmt:get-run-name-from-id run-id)) +(test #f + (vector + header + (vector #f #f #f #f)) + (rmt:get-run-info run-id)) + +;; Insert data into db +;; +(test #f 1 (rmt:register-run keyvals runname "new" "n/a" user)) +;; (test #f #f (rmt:get-runs-by-patt keys runname)) +(test #f #t (rmt:general-call 'register-test run-id run-id "test-one" "")) +(define test-one-id #f) +(test #f 1 (let ((test-id (rmt:get-test-id run-id "test-one" ""))) + (set! test-one-id test-id) + test-id)) +(define test-one-rec #f) +(test #f "test-one" (let ((test-rec (rmt:get-test-info-by-id run-id test-one-id))) + (set! test-one-rec test-rec) + (vector-ref test-rec 2))) + +;; With data in db +;; +(print "Using runame=" runname) +(test #f '(1) (rmt:get-all-run-ids)) +(test #f runname (rmt:get-run-name-from-id run-id)) +(test #f + runname + (let ((run-info (rmt:get-run-info run-id))) + (db:get-value-by-header (db:get-rows run-info) + (db:get-header run-info) + "runname"))) + +;; test killing server +;; +(for-each + (lambda (run-id) + (test #f #t (and (tasks:kill-server-run-id run-id) #t)) + (test #f #f (tasks:server-running-or-starting? (db:delay-if-busy (tasks:open-db)) run-id))) + (list 0 1)) + +;; Tests to assess reading/writing while servers are starting/stopping +;; NO LONGER APPLICABLE + +;; Server tests go here +(define (server-tests-dont-run-right-now) (for-each (lambda (run-id) (test #f #f (tasks:server-running-or-starting? (db:delay-if-busy (tasks:open-db)) run-id)) (server:kind-run run-id) (test "did server start within 20 seconds?" @@ -51,82 +131,14 @@ (begin (thread-sleep! 1.1) (loop (- remtries 1)(tasks:get-server (db:delay-if-busy (tasks:open-db)) run-id))) res))))) ) - (list 0 1)) - -(define user (current-user-name)) -(define runname "mytestrun") -(define keys (rmt:get-keys)) -(define runinfo #f) -(define keyvals '(("SYSTEM" "abc")("RELEASE" "def"))) -(define header (list "SYSTEM" "RELEASE" "id" "runname" "state" "status" "owner" "event_time")) - -;; Setup -;; -(test #f #f (not (client:setup run-id))) -(test #f #f (not (hash-table-ref/default *runremote* run-id #f))) - -;; Login -;; -(test #f'(#t "successful login") - (rmt:login-no-auto-client-setup (hash-table-ref/default *runremote* run-id #f) run-id)) -(test #f '(#t "successful login") - (rmt:login run-id)) - -;; Keys -;; -(test #f '("SYSTEM" "RELEASE") (rmt:get-keys)) - -;; No data in db -;; -(test #f '() (rmt:get-all-run-ids)) -(test #f #f (rmt:get-run-name-from-id run-id)) -(test #f - (vector - header - (vector #f #f #f #f)) - (rmt:get-run-info run-id)) - -;; Insert data into db -;; -(test #f 1 (rmt:register-run keyvals runname "new" "n/a" user)) -;; (test #f #f (rmt:get-runs-by-patt keys runname)) -(test #f #t (rmt:general-call 'register-test run-id run-id "test-one" "")) -(define test-one-id #f) -(test #f 30001 (let ((test-id (rmt:get-test-id run-id "test-one" ""))) - (set! test-one-id test-id) - test-id)) -(define test-one-rec #f) -(test #f "test-one" (let ((test-rec (rmt:get-test-info-by-id run-id test-one-id))) - (set! test-one-rec test-rec) - (vector-ref test-rec 2))) - -;; With data in db -;; -(print "Using runame=" runname) -(test #f '(1) (rmt:get-all-run-ids)) -(test #f runname (rmt:get-run-name-from-id run-id)) -(test #f - runname - (let ((run-info (rmt:get-run-info run-id))) - (db:get-value-by-header (db:get-rows run-info) - (db:get-header run-info) - "runname"))) - -(for-each (lambda (run-id) -;; test killing server -;; -(tasks:kill-server-run-id run-id) - -(test #f #f (tasks:server-running-or-starting? (db:delay-if-busy (tasks:open-db)) run-id)) -) -(list 0 1)) - -;; Tests to assess reading/writing while servers are starting/stopping -(define start-time (current-seconds)) + (list 0 1))) + +(define start-time (current-seconds)) +(define (reading-writing-while-server-starting-stopping-dont-run-now) (let loop ((test-state 'start)) (let* ((server-dats (tasks:get-server-records (db:delay-if-busy (tasks:open-db)) run-id)) (first-dat (if (not (null? server-dats)) (car server-dats) #f))) @@ -149,11 +161,11 @@ ((shutting-down) (loop test-state)) (else (print "Don't know what to do if get here")))) ((server-shutdown) (loop test-state))))) - +) ;;====================================================================== ;; END OF TESTS ;;====================================================================== Index: tests/unittests/configfiles.scm ================================================================== --- tests/unittests/configfiles.scm +++ tests/unittests/configfiles.scm @@ -1,8 +1,24 @@ ;;====================================================================== ;; C O N F I G F I L E S ;;====================================================================== +;; Copyright 2006-2017, Matthew Welland. +;; +;; This file is part of Megatest. +;; +;; Megatest is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. +;; +;; Megatest is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with Megatest. If not, see . (define conffile #f) (test "Read a config" #t (hash-table? (read-config "test.config" #f #f))) (test "Read a config that doesn't exist" #t (hash-table? (read-config "nada.config" #f #f))) ADDED tests/unittests/cron.scm Index: tests/unittests/cron.scm ================================================================== --- /dev/null +++ tests/unittests/cron.scm @@ -0,0 +1,35 @@ +;; Copyright 2006-2017, Matthew Welland. +;; +;; This file is part of Megatest. +;; +;; Megatest is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. +;; +;; Megatest is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with Megatest. If not, see . + +(use test) + +;; S M H MD MTH YR WD +(define ref-time (vector 58 39 21 18 1 117 6 48 #f 25200)) + +(for-each + (lambda (situation crontab ref-seconds last-done expected) + (print "\nsituation: " situation) + (print "ref-seconds: " ref-seconds " = " (time->string (seconds->local-time ref-seconds))) + (print "last-done: " last-done " = " (time->string (seconds->local-time last-done))) + (print "crontab: " crontab) + (test #f expected (common:cron-event crontab ref-seconds last-done))) + '("midnight" "midnight, already done" "diffdate" "diffdate, already done" "diffday" "sameday, already done") + '("0 0 * * *" "0 0 * * *" "0 0 18 * *" "0 0 18 * *" "0 0 * * 5" "0 0 18 * 6" ) + '(1487489998.0 1487489998.0 1487489998.0 1487489998.0 1487489998.0 1487489998.0 ) + '(1487479198.0 1487489098.0 1487479198.0 1487489098.0 1487479198.0 1487489098.0 ) + '( #t #f #f #f #f #f ) + ) Index: tests/unittests/dbrdbstruct.scm ================================================================== --- tests/unittests/dbrdbstruct.scm +++ tests/unittests/dbrdbstruct.scm @@ -1,8 +1,25 @@ ;;====================================================================== ;; S E R V E R ;;====================================================================== +;; Copyright 2006-2017, Matthew Welland. +;; +;; This file is part of Megatest. +;; +;; Megatest is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. +;; +;; Megatest is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with Megatest. If not, see . + ;; Run like this: ;; ;; (cd ..;make && make install) && ./rununittest.sh server 1;(cd simplerun;megatest -stop-server 0) Index: tests/unittests/inmemdb.scm ================================================================== --- tests/unittests/inmemdb.scm +++ tests/unittests/inmemdb.scm @@ -1,8 +1,24 @@ ;;====================================================================== ;; S E R V E R ;;====================================================================== +;; Copyright 2006-2017, Matthew Welland. +;; +;; This file is part of Megatest. +;; +;; Megatest is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. +;; +;; Megatest is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with Megatest. If not, see . ;; Run like this: ;; ;; (cd ..;make && make install) && ./rununittest.sh server 1;(cd simplerun;megatest -stop-server 0) Index: tests/unittests/misc.scm ================================================================== --- tests/unittests/misc.scm +++ tests/unittests/misc.scm @@ -1,5 +1,22 @@ +;; Copyright 2006-2017, Matthew Welland. +;; +;; This file is part of Megatest. +;; +;; Megatest is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. +;; +;; Megatest is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with Megatest. If not, see . + (use sqlite3) ;;====================================================================== ;; P R O C E S S E S ;;====================================================================== Index: tests/unittests/runs.scm ================================================================== --- tests/unittests/runs.scm +++ tests/unittests/runs.scm @@ -1,6 +1,25 @@ +;; Copyright 2006-2017, Matthew Welland. +;; +;; This file is part of Megatest. +;; +;; Megatest is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. +;; +;; Megatest is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with Megatest. If not, see . + (define keys (rmt:get-keys)) + +(test #f #t (and (server:kind-run *toppath*) #t)) (test "get all legal tests" (list "test1" "test2") (sort (hash-table-keys (tests:get-all)) string<=?)) (test "register-run" #t (number? (rmt:register-run @@ -9,12 +28,12 @@ "new" "n/a" "bob"))) (test #f #t (rmt:register-test 1 "nada" "")) -(test #f 30001 (rmt:get-test-id 1 "nada" "")) -(test #f "NOT_STARTED" (vector-ref (rmt:get-test-info-by-id 1 30001) 3)) ;; "nada" "") 3)) +(test #f 1 (rmt:get-test-id 1 "nada" "")) +(test #f "NOT_STARTED" (vector-ref (rmt:get-test-info-by-id 1 1) 3)) (test #f "FOO LIKE 'abc%def'" (db:patt->like "FOO" "abc%def")) (test #f "key2" (vector-ref (car (vector-ref (mt:get-runs-by-patt '("SYSTEM" "RELEASE") "%" "key1/key2") 1)) 1)) (test #f "SYSTEM,RELEASE,id,runname,state,status,owner,event_time" (car (runs:get-std-run-fields keys '("id" "runname" "state" "status" "owner" "event_time")))) @@ -49,11 +68,11 @@ ; (hash-table-set! args:arg-hash "-keepgoing" #t) (hash-table-set! args:arg-hash "-itempatt" "%") (hash-table-set! args:arg-hash "-testpatt" "%") (hash-table-set! args:arg-hash "-target" "ubuntu/r1.2") ;; SYSTEM/RELEASE (hash-table-set! args:arg-hash "-runname" "testrun") -(test "Setup for a run" #t (begin (launch:setup-for-run) #t)) +(test "Setup for a run" #t (string? (launch:setup))) (define *tdb* #f) (define keyvals #f) (test "target->keyval" #t (let ((kv (keys:target->keyval keys (args:get-arg "-target")))) (print "keyvals=" kv ", keys=" keys) @@ -151,11 +170,11 @@ (test "launch-test" #t (string? (file-exists? ;; (launch-test test-id run-id run-info keyvals runname test-conf test-name test-path itemdat params) - (launch-test 30001 1 rinfo keyvals "run1" tconfig "test1" test-path '() (make-hash-table))))) + (launch-test 1 1 rinfo keyvals "run1" tconfig "test1" test-path '() (make-hash-table))))) ;;====================================================================== ;; M O R E R E M O T E C A L L S ;;====================================================================== @@ -169,13 +188,18 @@ ;; T E S T I T E M M A P ;;====================================================================== (test #f "a/b/c" (db:multi-pattern-apply "d/e/f" "d a\ne b\nf c")) (test #f "blah/foo/bar/baz" (db:convert-test-itempath "blah/baz/bar/foo" "^([^/]+)/([^/]+)/([^/]+)$ \\3/\\2/\\1")) -(test #f #t (db:compare-itempaths "abc/def/123" "abc/ghi/123" "ghi def")) -(test #f #f (db:compare-itempaths "some/5" "item/5" ".*/")) -(test #f #t (db:compare-itempaths "some/5" "item/5" ".*/ some/")) +(define itemmaps (alist->hash-table + '(("test1" "ghi def") + ("test2" ".*/") + ("test3" ".*/ some/")))) + +(test #f #t (db:compare-itempaths "test1" "abc/def/123" "abc/ghi/123" itemmaps)) +(test #f #f (db:compare-itempaths "test2" "some/5" "item/5" ".*/" itemmaps)) +(test #f #t (db:compare-itempaths "test3" "some/5" "item/5" ".*/ some/" itemmaps)) (test #f '() (rmt:get-prereqs-not-met 1 '("rollup") "some/5" mode: '(toplevel) itemmap: ".*/" "/")) (test #f '() (rmt:get-prereqs-not-met 1 '("rollup") "some/5" mode: '(normal) itemmap: ".*/" "/")) (test #f '() (rmt:get-prereqs-not-met 1 '("rollup") "some/5" mode: '(itemmatch) itemmap: ".*/" "/")) (test #f '() (rmt:get-prereqs-not-met 1 '("rollup") "some/5" mode: '(itemwait) itemmap: ".*/" "/")) Index: tests/unittests/server.scm ================================================================== --- tests/unittests/server.scm +++ tests/unittests/server.scm @@ -1,8 +1,25 @@ ;;====================================================================== ;; S E R V E R ;;====================================================================== +;; Copyright 2006-2017, Matthew Welland. +;; +;; This file is part of Megatest. +;; +;; Megatest is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. +;; +;; Megatest is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with Megatest. If not, see . + ;; Run like this: ;; ;; (cd ..;make && make install) && ./rununittest.sh server 1;(cd simplerun;megatest -stop-server 0) Index: tests/unittests/tests.scm ================================================================== --- tests/unittests/tests.scm +++ tests/unittests/tests.scm @@ -1,6 +1,23 @@ ;; ;;====================================================================== +;; Copyright 2006-2017, Matthew Welland. +;; +;; This file is part of Megatest. +;; +;; Megatest is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. +;; +;; Megatest is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with Megatest. If not, see . + ;; ;; itemwait, itemmatch ;; ;; (db:compare-itempaths ref-item-path item-path itemmap) ;; ;; ;; prereqs-not-met @@ -12,69 +29,72 @@ ;; (non-completed (runs:calc-not-completed prereqs-not-met)) ;; (runnables (runs:calc-runnable prereqs-not-met))) ;; ;; ;; - (define user (current-user-name)) (define runname "mytestrun") (define keys (rmt:get-keys)) (define runinfo #f) (define keyvals '(("SYSTEM" "abc")("RELEASE" "def"))) (define header (list "SYSTEM" "RELEASE" "id" "runname" "state" "status" "owner" "event_time")) +(define contour #f) (define run-id 1) - +(define new-comment #f) ;; Create a run -(test #f 1 (rmt:register-run keyvals runname "new" "n/a" user)) +(test #f 1 (rmt:register-run keyvals runname "new" "n/a" user contour)) (test #f #t (rmt:general-call 'register-test run-id run-id "test-one" "")) (test #f #t (rmt:general-call 'register-test run-id run-id "test-two" "")) (test #f #t (rmt:general-call 'register-test run-id run-id "test-three" "")) (test #f #t (rmt:general-call 'register-test run-id run-id "test-four" "")) -(rmt:test-set-state-status-by-id run-id (rmt:get-test-id run-id "test-one" "") "COMPLETED" "FAIL" "") -(rmt:test-set-state-status-by-id run-id (rmt:get-test-id run-id "test-two" "") "COMPLETED" "PASS" "") -(rmt:test-set-state-status-by-id run-id (rmt:get-test-id run-id "test-three" "") "RUNNING" "n/a" "") -(rmt:test-set-state-status-by-id run-id (rmt:get-test-id run-id "test-four" "") "COMPLETED" "WARN" "") + +;; (define (rmt:test-set-state-status-by-id run-id test-id newstate newstatus newcomment) +(rmt:test-set-state-status-by-id run-id (rmt:get-test-id run-id "test-one" "") "COMPLETED" "FAIL" new-comment) +(rmt:test-set-state-status-by-id run-id (rmt:get-test-id run-id "test-two" "") "COMPLETED" "PASS" new-comment) +(rmt:test-set-state-status-by-id run-id (rmt:get-test-id run-id "test-three" "") "RUNNING" "n/a" new-comment) +(rmt:test-set-state-status-by-id run-id (rmt:get-test-id run-id "test-four" "") "COMPLETED" "WARN" new-comment) -(print "MODE=not in") -(test #f '() +(test "MODE=not in" + '() (filter (lambda (y) (equal? y "FAIL")) ;; any FAIL in the output list? (map (lambda (x)(vector-ref x 4)) (rmt:get-tests-for-run run-id "%/%" '() '("FAIL") #f #f #t 'event_time "DESC" 'shortlist 0 'dashboard)))) -(print "MODE=in") -(test #f '("FAIL") +(test "MODE=in" + '("FAIL") (map (lambda (x)(vector-ref x 4)) (rmt:get-tests-for-run run-id "%/%" '() '("FAIL") #f #f #f 'event_time "DESC" 'shortlist 0 'dashboard))) (set! *verbosity* 1) -(print "MODE=in, state in RUNNING") ;; (set! *verbosity* 8) -(test #f '("RUNNING") +(test "MODE=in, state in RUNNING" '("RUNNING") (map (lambda (x)(vector-ref x 3)) (rmt:get-tests-for-run run-id "%/%" '("RUNNING") '() #f #f #f 'event_time "DESC" 'shortlist 0 'dashboard))) (set! *verbosity* 1) -(print "MODE=in, state in RUNNING and status IN WARN") ;; (set! *verbosity* 8) -(test #f '(("RUNNING" . "n/a") ("COMPLETED" . "WARN")) - (map - (lambda (x) - (cons (vector-ref x 3)(vector-ref x 4))) - (rmt:get-tests-for-run run-id "%/%" '("RUNNING") '("WARN") #f #f #f 'event_time "DESC" 'shortlist 0 'dashboard))) +;;(define (rmt:get-tests-for-run run-id testpatt states statuses offset limit not-in sort-by sort-order qryvals last-update mode) +(test + "MODE=in, state in RUNNING and status IN WARN" + '(("COMPLETED" . "WARN") ("RUNNING" . "n/a") ) + (map + (lambda (x) + (cons (vector-ref x 3)(vector-ref x 4))) + (rmt:get-tests-for-run run-id "%/%" '("RUNNING") '("WARN") #f #f #f 'event_time "DESC" 'shortlist 0 'dashboard))) (set! *verbosity* 1) -(print "MODE=not in, state in RUNNING and status IN WARN") (set! *verbosity* 8) -(test #f '(("DELETED" . "n/a") ("COMPLETED" . "PASS") ("COMPLETED" . "FAIL")) +(test "MODE=not in, state in RUNNING and status IN WARN" + '(("COMPLETED" . "PASS") ("COMPLETED" . "FAIL")) (map (lambda (x) (cons (vector-ref x 3)(vector-ref x 4))) (rmt:get-tests-for-run run-id "%/%" '("RUNNING") '("WARN") #f #f #t 'event_time "DESC" 'shortlist 0 'dashboard))) (set! *verbosity* 1) (exit) Index: tests/vectors-vs-records.scm ================================================================== --- tests/vectors-vs-records.scm +++ tests/vectors-vs-records.scm @@ -1,5 +1,22 @@ +;; Copyright 2006-2017, Matthew Welland. +;; +;; This file is part of Megatest. +;; +;; Megatest is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. +;; +;; Megatest is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with Megatest. If not, see . +;; (use srfi-9) (define numtodo (string->number (caddr (argv)))) ;; using vectors Index: tests/watch-monitor.sh ================================================================== --- tests/watch-monitor.sh +++ tests/watch-monitor.sh @@ -1,7 +1,24 @@ #!/bin/bash +# Copyright 2006-2017, Matthew Welland. +# +# This file is part of Megatest. +# +# Megatest is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# Megatest is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with Megatest. If not, see . + if [ -e fullrun/db/monitor.db ];then sqlite3 fullrun/db/monitor.db << EOF .header on .mode column select * from servers order by start_time desc; DELETED testzmq/hwclient.scm Index: testzmq/hwclient.scm ================================================================== --- testzmq/hwclient.scm +++ /dev/null @@ -1,16 +0,0 @@ -(use zmq posix srfi-18) - -(define s (make-socket 'req)) -(connect-socket s "tcp://*:5563") - -(define myname (cadr (argv))) - -(print "Start client...") - -(do ((i 0 (+ i 1))) - ((>= i 1000)) - (print "sending message #" i) - (send-message s (conc "Hello from " myname)) - (print "sent \"Hello\", looking for a reply") - (printf "Received reply ~a [~a]\n" - i (receive-message s))) DELETED testzmq/hwserver.scm Index: testzmq/hwserver.scm ================================================================== --- testzmq/hwserver.scm +++ /dev/null @@ -1,28 +0,0 @@ -(use zmq srfi-18 posix) - -(define th1 (make-thread - (lambda () - (let ((s (make-socket 'rep))) - (bind-socket s "tcp://*:5563") - (print "Start server...") - (let loop () - (let* ((msg (receive-message s)) - (name (caddr (string-split msg " "))) - (resp (conc "World " name))) - (print "Received request: [" msg "]") - (thread-sleep! 0.0001) - (print "Sending response \"" resp "\"") - (send-message s resp) - (loop))))))) -(define th2 (make-thread - (lambda () - (let loop ((count 0)) - (print "count is " count) - (thread-sleep! 0.1) - (if (< count 10000) - (loop (+ count 1))))))) - -(thread-start! th1) -(thread-start! th2) - -(thread-join! th1) DELETED testzmq/hwtest.sh Index: testzmq/hwtest.sh ================================================================== --- testzmq/hwtest.sh +++ /dev/null @@ -1,14 +0,0 @@ -#!/bin/bash - -echo Compiling hwclient and hwserver -csc hwclient.scm -csc hwserver.scm - -./hwserver > hwserver.log & - -sleep 1 -for x in a b c d e f g h i j k l m n o p q r s t u v w x y z;do -./hwclient $x & -done - -# killall -v hwserver hwclient DELETED testzmq/mockupclient.scm Index: testzmq/mockupclient.scm ================================================================== --- testzmq/mockupclient.scm +++ /dev/null @@ -1,42 +0,0 @@ -(use zmq posix numbers) - -(define cname "Bob") -(define runtime 10) -(let ((args (argv))) - (if (< (length args) 3) - (begin - (print "Usage: mockupclient clientname runtime") - (exit)) - (begin - (set! cname (cadr args)) - (set! runtime (string->number (caddr args)))))) - -;; (define start-delay (/ (random 100) 9)) -;; (define runtime (+ 1 (/ (random 200) 2))) - -(print "Starting client " cname " with runtime " runtime) - -(include "mockupclientlib.scm") - -(set! endtime (+ (current-seconds) runtime)) - -;; first ping the server to ensure we have a connection -(if (server-ping cname 5) - (print "SUCCESS: Client " cname " connected to server") - (begin - (print "ERROR: Client " cname " failed ping of server, exiting") - (exit))) - -(let loop () - (let ((x (random 15)) - (varname (list-ref (list "hello" "goodbye" "saluton" "kiaorana")(random 4)))) - (case x - ;; ((1)(dbaccess cname 'sync "nodat" #f)) - ((2 3 4 5)(dbaccess cname 'set varname (random 999))) - ((6 7 8 9 10)(print cname ": Get \"" varname "\" " (dbaccess cname 'get varname #f))) - (else - (thread-sleep! 0.011))) - (if (< (current-seconds) endtime) - (loop)))) - -(print "Client " cname " all done!!") DELETED testzmq/mockupclientlib.scm Index: testzmq/mockupclientlib.scm ================================================================== --- testzmq/mockupclientlib.scm +++ /dev/null @@ -1,63 +0,0 @@ -(define sub (make-socket 'sub)) -(define push (make-socket 'push)) -(socket-option-set! sub 'subscribe cname) -(socket-option-set! sub 'hwm 1000) -(socket-option-set! push 'hwm 1000) - -(connect-socket sub "tcp://localhost:6563") -(connect-socket push "tcp://localhost:6564") - -(thread-sleep! 0.2) - -(define (server-ping cname timeout) - (let ((msg (conc cname ":ping:" timeout)) - (maxtime (+ (current-seconds) timeout))) - (print "pinging server from " cname " with timeout " timeout) - (let loop ((res #f)) - (if (< maxtime (current-seconds)) - #f ;; failed to ping - (if (equal? res "Got ping") - #t - (begin - (print "Ping received from server " res) - (send-message push msg) - (thread-sleep! 0.1) - (loop (receive-message sub non-blocking: #t)))))))) - -(define (dbaccess cname cmd var val #!key (numtries 20)) - (let* ((msg (conc cname ":" cmd ":" (if val (conc var " " val) var))) - (res #f) - (mtx1 (make-mutex)) - (do-access (lambda () - (let ((tmpres #f)) - (print "Sending msg: " msg) - (send-message push msg) - (print "Message " msg " sent") - (print "Client " cname " waiting for response to " msg) - (print "Client " cname " received address " (receive-message* sub)) - (set! tmpres (receive-message* sub)) - (mutex-lock! mtx1) - (set! res tmpres) - (mutex-unlock! mtx1)))) - (th1 (make-thread do-access "do access")) - (th2 (make-thread (lambda () - (let ((result #f)) - (mutex-lock! mtx1) - (set! result res) - (mutex-unlock! mtx1) - (thread-sleep! 5) - (if (not result) - (if (> numtries 0) - (begin - (print "WARNING: access timed out for " cname ", trying again. Trys remaining=" numtries) - (dbaccess cname cmd var val numtries: (- numtries 1))) - (begin - (print "ERROR: dbaccess timed out. Exiting") - (exit))))) - "timeout thread")))) - (thread-start! th1) - (thread-start! th2) - (thread-join! th1) - (if res (print "SUCCESS: received " res " with " numtries " remaining possible attempts")) - res)) - DELETED testzmq/mockupserver.scm Index: testzmq/mockupserver.scm ================================================================== --- testzmq/mockupserver.scm +++ /dev/null @@ -1,151 +0,0 @@ -;; pub/sub with envelope address -;; Note that if you don't insert a sleep, the server will crash with SIGPIPE as soon -;; as a client disconnects. Also a remaining client may receive tons of -;; messages afterward. - -(use zmq srfi-18 sqlite3 numbers) - -(define pub (make-socket 'pub)) -(define pull (make-socket 'pull)) -(define cname "server") -(define total-db-accesses 0) -(define start-time (current-seconds)) - -(socket-option-set! pub 'hwm 1000) -(socket-option-set! pull 'hwm 1000) - -(bind-socket pub "tcp://*:6563") -(bind-socket pull "tcp://*:6564") - -(thread-sleep! 0.2) - -(define (open-db) - (let* ((dbpath "mockup.db") - (dbexists (file-exists? dbpath)) - (db (open-database dbpath)) ;; (never-give-up-open-db dbpath)) - (handler (make-busy-timeout 10))) - (set-busy-handler! db handler) - (if (not dbexists) - (for-each - (lambda (stmt) - (execute db stmt)) - (list - "PRAGMA SYNCHRONOUS=0;" - "CREATE TABLE clients (id INTEGER PRIMARY KEY,name TEXT,num_accesses INTEGER DEFAULT 0);" - "CREATE TABLE vars (var TEXT,val TEXT,CONSTRAINT vars_constraint UNIQUE (var));"))) - db)) - -(define cid-cache (make-hash-table)) - -(define (get-client-id db cname) - (let ((cid (hash-table-ref/default cid-cache cname #f))) - (if cid - cid - (begin - (execute db "INSERT OR REPLACE INTO clients (name) VALUES(?);" cname) - (for-each-row - (lambda (id) - (set! cid id)) - db - "SELECT id FROM clients WHERE name=?;" cname) - (hash-table-set! cid-cache cname cid) - (set! total-db-accesses (+ total-db-accesses 2)) - cid)))) - -(define (count-client db cname) - (let ((cid (get-client-id db cname))) - (execute db "UPDATE clients SET num_accesses=num_accesses+1 WHERE id=?;" cid) - (set! total-db-accesses (+ total-db-accesses 1)) - )) - -(define db (open-db)) -;; (define queuelst '()) -;; (define mx1 (make-mutex)) - -(define max-queue-len 0) - -(define (process-queue queuelst) - (let ((queuelen (length queuelst))) - (if (> queuelen max-queue-len) - (set! max-queue-len queuelen)) - (for-each - (lambda (item) - (let ((cname (vector-ref item 1)) - (clcmd (vector-ref item 2)) - (cdata (vector-ref item 3))) - (send-message pub cname send-more: #t) - (send-message pub (case clcmd - ((sync) - (conc queuelen)) - ((set) - (set! total-db-accesses (+ total-db-accesses 1)) - (apply execute db "INSERT OR REPLACE INTO vars (var,val) VALUES (?,?);" (string-split cdata)) - "ok") - ((get) - (set! total-db-accesses (+ total-db-accesses 1)) - (let ((res "noval")) - (for-each-row - (lambda (val) - (set! res val)) - db - "SELECT val FROM vars WHERE var=?;" cdata) - res)) - (else (conc "unk cmd: " clcmd)))))) - queuelst))) - -;; SERVER THREAD -(define th1 (make-thread - (lambda () - (let ((last-run 0)) ;; current-seconds when run last - (let loop ((queuelst '())) - (let* ((indat (receive-message* pull)) - (parts (string-split indat ":")) - (cname (car parts)) ;; client name - (clcmd (string->symbol (cadr parts))) ;; client cmd - (cdata (caddr parts)) ;; client data - (svect (vector (current-seconds) cname clcmd cdata))) ;; record for the queue - ;; (print "Server received message: " indat) - (count-client db cname) - (case clcmd - ((ping) - (print "Got ping from " cname) - (send-message pub cname send-more: #t) - (send-message pub "Got ping") - (loop queuelst)) - ((sync) ;; just process the queue - (print "Got sync from " cname) - (process-queue (cons svect queuelst)) - (loop '())) - ((get) - (process-queue (cons svect queuelst)) - (loop '())) - (else - (loop (cons svect queuelst)))))))) - "server thread")) - -(include "mockupclientlib.scm") - -;; SYNC THREAD -;; send a sync to the pull port -(define th2 (make-thread - (lambda () - (let ((last-action-time (current-seconds))) - (let loop () - (thread-sleep! 5) - (let ((queuelen (string->number (dbaccess "server" 'sync "nada" #f))) - (last-action-delta #f)) - (if (> queuelen 1)(set! last-action-time (current-seconds))) - (set! last-action-delta (- (current-seconds) last-action-time)) - (print "Server: Got queuelen=" queuelen ", last-action-delta=" last-action-delta) - (if (< last-action-delta 60) - (loop) - (print "Server exiting, 25 seconds since last access")))))) - "sync thread")) - -(thread-start! th1) -(thread-start! th2) -(thread-join! th2) - -(let* ((run-time (- (current-seconds) start-time)) - (queries/second (/ total-db-accesses run-time))) - (print "Server exited! Total db accesses=" total-db-accesses " in " run-time " seconds for " queries/second " queries/second with max queue length of: " max-queue-len)) DELETED testzmq/random.scm Index: testzmq/random.scm ================================================================== --- testzmq/random.scm +++ /dev/null @@ -1,8 +0,0 @@ -(use posix numbers) -(randomize (inexact->exact (current-seconds))) - -(define low (string->number (cadr (argv)))) -(define hi (string->number (caddr (argv)))) - -(print (+ low (random (- hi low)))) - DELETED testzmq/testmockup.sh Index: testzmq/testmockup.sh ================================================================== --- testzmq/testmockup.sh +++ /dev/null @@ -1,41 +0,0 @@ -#!/bin/bash - -rm -f mockup.db - -echo Compiling mockupserver.scm and mockupclient.scm - -# Clean up first -killall mockupserver mockupclient -v - -csc random.scm -csc mockupserver.scm -csc mockupclient.scm - -echo Starting server -./mockupserver & - -sleep 1 - -rm -f mockupclients.log - -echo Starting clients -for i in a b c d e f g h i j k l m n o p q s t u v w x y z; - do - for k in a b; - do - for j in 0 1 2 3 4 5 6 7 8 9; - do - waittime=`./random 0 60` - runtime=`./random 5 120` - echo "Starting client $i$k$j with waittime $waittime and runtime $runtime" - (sleep $waittime;./mockupclient $i$k$j $runtime) & - # >> mockupclients.log & - done - done -done - -wait -echo testmockup.sh script done -# echo "Waiting for 5 seconds then killing all mockupserver and mockupclient processes" -# sleep 30 -# killall -v mockupserver mockupclient ADDED trackback.scm Index: trackback.scm ================================================================== --- /dev/null +++ trackback.scm @@ -0,0 +1,53 @@ +;; Copyright 2006-2017, Matthew Welland. +;; +;; This file is part of Megatest. +;; +;; Megatest is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. +;; +;; Megatest is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with Megatest. If not, see . + +(include "codescanlib.scm") + +;; show call paths for named procedure +(define (traceback-proc in-procname) + (letrec* ((all-scm-files (glob "*.scm")) + (xref (get-xref all-scm-files)) + (have (alist-ref (string->symbol in-procname) xref eq? #f)) + (lookup (lambda (path procname depth) + (let* ((upcone-temp (filter (lambda (x) + (eq? procname (car x))) + xref)) + (upcone-temp2 (cond + ((null? upcone-temp) '()) + (else (cdar upcone-temp)))) + (upcone (filter + (lambda (x) (not (eq? x procname))) + upcone-temp2)) + (uppath (cons procname path)) + (updepth (add1 depth))) + (if (null? upcone) + (print uppath) + (for-each (lambda (x) + (if (not (member procname path)) + (lookup uppath x updepth) )) + upcone)))))) + (if have + (lookup '() (string->symbol in-procname) 0) + (print "no such func - "in-procname)))) + + +(if (eq? 1 (length (command-line-arguments))) + (traceback-proc (car (command-line-arguments))) + (print "Usage: trackback ")) + +(exit 0) + Index: tree.scm ================================================================== --- tree.scm +++ tree.scm @@ -1,14 +1,23 @@ ;;====================================================================== ;; Copyright 2006-2013, Matthew Welland. ;; -;; This program is made available under the GNU GPL version 2.0 or -;; greater. See the accompanying file COPYING for details. +;; This file is part of Megatest. +;; +;; Megatest is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. +;; +;; Megatest is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. ;; -;; This program is distributed WITHOUT ANY WARRANTY; without even the -;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR -;; PURPOSE. +;; You should have received a copy of the GNU General Public License +;; along with Megatest. If not, see . +;; ;;====================================================================== (use format) (require-library iup) (import (prefix iup iup:)) @@ -18,17 +27,18 @@ (import (prefix sqlite3 sqlite3:)) (declare (unit tree)) (declare (uses margs)) (declare (uses launch)) -(declare (uses megatest-version)) +;; (declare (uses megatest-version)) (declare (uses gutils)) (declare (uses db)) (declare (uses server)) -(declare (uses synchash)) +;; (declare (uses synchash)) (declare (uses dcommon)) +(include "megatest-version.scm") (include "common_records.scm") (include "db_records.scm") (include "key_records.scm") ;;====================================================================== @@ -69,11 +79,14 @@ (define (tree:add-node obj top nodelst #!key (userdata #f)) (let ((curr-top (iup:attribute obj "TITLE0"))) (if (or (not (string? curr-top)) (string-null? curr-top) (string-match "^\\s*$" curr-top)) - (iup:attribute-set! obj "ADDBRANCH0" top)) + (iup:attribute-set! obj "ADDBRANCH0" top)) + + + (cond ((not (equal? top (iup:attribute obj "TITLE0"))) (print "ERROR: top name " top " doesn't match " (iup:attribute obj "TITLE0"))) ((null? nodelst)) (else @@ -135,10 +148,10 @@ ;; (print "obj: " obj ", id: " id ", state: " state) (let* ((run-path (tree:node->path obj id)) (run-id (tree-path->run-id (cdr run-path)))) (if run-id (begin - (dboard:data-curr-run-id-set! *data* run-id) + (dboard:data-curr-run-id-set! data run-id) (dashboard:update-run-summary-tab))) ;; (print "path: " (tree:node->path obj id) " run-id: " run-id) )))) |# DELETED txtdb/metadat.scm Index: txtdb/metadat.scm ================================================================== --- txtdb/metadat.scm +++ /dev/null @@ -1,553 +0,0 @@ -(define minimal-sxml - '(*TOP* (*PI* xml "version=\"1.0\" encoding=\"UTF-8\"") - (http://www.gnumeric.org/v10.dtd:Workbook - (@ (http://www.w3.org/2001/XMLSchema-instance:schemaLocation - "http://www.gnumeric.org/v9.xsd")) - (http://www.gnumeric.org/v10.dtd:Version - (@ (Minor "17") (Major "10") (Full "1.10.17") (Epoch "1"))) - (http://www.gnumeric.org/v10.dtd:Attributes - (http://www.gnumeric.org/v10.dtd:Attribute - (http://www.gnumeric.org/v10.dtd:type "4") - (http://www.gnumeric.org/v10.dtd:name - "WorkbookView::show_horizontal_scrollbar") - (http://www.gnumeric.org/v10.dtd:value "TRUE")) - (http://www.gnumeric.org/v10.dtd:Attribute - (http://www.gnumeric.org/v10.dtd:type "4") - (http://www.gnumeric.org/v10.dtd:name - "WorkbookView::show_vertical_scrollbar") - (http://www.gnumeric.org/v10.dtd:value "TRUE")) - (http://www.gnumeric.org/v10.dtd:Attribute - (http://www.gnumeric.org/v10.dtd:type "4") - (http://www.gnumeric.org/v10.dtd:name - "WorkbookView::show_notebook_tabs") - (http://www.gnumeric.org/v10.dtd:value "TRUE")) - (http://www.gnumeric.org/v10.dtd:Attribute - (http://www.gnumeric.org/v10.dtd:type "4") - (http://www.gnumeric.org/v10.dtd:name - "WorkbookView::do_auto_completion") - (http://www.gnumeric.org/v10.dtd:value "TRUE")) - (http://www.gnumeric.org/v10.dtd:Attribute - (http://www.gnumeric.org/v10.dtd:type "4") - (http://www.gnumeric.org/v10.dtd:name - "WorkbookView::is_protected") - (http://www.gnumeric.org/v10.dtd:value "FALSE"))) - (urn:oasis:names:tc:opendocument:xmlns:office:1.0:document-meta - (@ (urn:oasis:names:tc:opendocument:xmlns:office:1.0:version "1.2")) - (urn:oasis:names:tc:opendocument:xmlns:office:1.0:meta - (http://purl.org/dc/elements/1.1/:date "2013-07-26T05:41:51Z") - (urn:oasis:names:tc:opendocument:xmlns:meta:1.0:creation-date - "2013-07-26T05:41:10Z"))) - (http://www.gnumeric.org/v10.dtd:Calculation - (@ (MaxIterations "100") - (ManualRecalc "0") - (IterationTolerance "0.001") - (FloatRadix "2") - (FloatDigits "53") - (EnableIteration "1"))) - (http://www.gnumeric.org/v10.dtd:SheetNameIndex - (http://www.gnumeric.org/v10.dtd:SheetName - (@ (http://www.gnumeric.org/v10.dtd:Rows "65536") - (http://www.gnumeric.org/v10.dtd:Cols "256")) - "Sheet1")) - (http://www.gnumeric.org/v10.dtd:Geometry - (@ (Width "1440") (Height "647"))) - (http://www.gnumeric.org/v10.dtd:Sheets - (http://www.gnumeric.org/v10.dtd:Sheet - (@ (Visibility "GNM_SHEET_VISIBILITY_VISIBLE") - (OutlineSymbolsRight "1") - (OutlineSymbolsBelow "1") - (HideZero "0") - (HideRowHeader "0") - (HideGrid "0") - (HideColHeader "0") - (GridColor "0:0:0") - (DisplayOutlines "1") - (DisplayFormulas "0")) - (http://www.gnumeric.org/v10.dtd:Name "Sheet1") - (http://www.gnumeric.org/v10.dtd:MaxCol "-1") - (http://www.gnumeric.org/v10.dtd:MaxRow "-1") - (http://www.gnumeric.org/v10.dtd:Zoom "1") - (http://www.gnumeric.org/v10.dtd:Names - (http://www.gnumeric.org/v10.dtd:Name - (http://www.gnumeric.org/v10.dtd:name "Print_Area") - (http://www.gnumeric.org/v10.dtd:value "#REF!") - (http://www.gnumeric.org/v10.dtd:position "A1")) - (http://www.gnumeric.org/v10.dtd:Name - (http://www.gnumeric.org/v10.dtd:name "Sheet_Title") - (http://www.gnumeric.org/v10.dtd:value "\"Sheet1\"") - (http://www.gnumeric.org/v10.dtd:position "A1"))) - (http://www.gnumeric.org/v10.dtd:PrintInformation - (http://www.gnumeric.org/v10.dtd:Margins - (http://www.gnumeric.org/v10.dtd:top - (@ (PrefUnit "mm") (Points "120"))) - (http://www.gnumeric.org/v10.dtd:bottom - (@ (PrefUnit "mm") (Points "120"))) - (http://www.gnumeric.org/v10.dtd:left - (@ (PrefUnit "mm") (Points "72"))) - (http://www.gnumeric.org/v10.dtd:right - (@ (PrefUnit "mm") (Points "72"))) - (http://www.gnumeric.org/v10.dtd:header - (@ (PrefUnit "mm") (Points "72"))) - (http://www.gnumeric.org/v10.dtd:footer - (@ (PrefUnit "mm") (Points "72")))) - (http://www.gnumeric.org/v10.dtd:Scale - (@ (type "percentage") (percentage "100"))) - (http://www.gnumeric.org/v10.dtd:vcenter (@ (value "0"))) - (http://www.gnumeric.org/v10.dtd:hcenter (@ (value "0"))) - (http://www.gnumeric.org/v10.dtd:grid (@ (value "0"))) - (http://www.gnumeric.org/v10.dtd:even_if_only_styles - (@ (value "0"))) - (http://www.gnumeric.org/v10.dtd:monochrome (@ (value "0"))) - (http://www.gnumeric.org/v10.dtd:draft (@ (value "0"))) - (http://www.gnumeric.org/v10.dtd:titles (@ (value "0"))) - (http://www.gnumeric.org/v10.dtd:do_not_print (@ (value "0"))) - (http://www.gnumeric.org/v10.dtd:print_range (@ (value "0"))) - (http://www.gnumeric.org/v10.dtd:order "d_then_r") - (http://www.gnumeric.org/v10.dtd:orientation "portrait") - (http://www.gnumeric.org/v10.dtd:Header - (@ (Right "") (Middle "&[TAB]") (Left ""))) - (http://www.gnumeric.org/v10.dtd:Footer - (@ (Right "") (Middle "Page &[PAGE]") (Left ""))) - (http://www.gnumeric.org/v10.dtd:paper "na_letter") - (http://www.gnumeric.org/v10.dtd:comments "in_place") - (http://www.gnumeric.org/v10.dtd:errors "as_displayed")) - (http://www.gnumeric.org/v10.dtd:Styles - (http://www.gnumeric.org/v10.dtd:StyleRegion - (@ (startRow "0") - (startCol "0") - (endRow "65535") - (endCol "255")) - (http://www.gnumeric.org/v10.dtd:Style - (@ (WrapText "0") - (VAlign "2") - (ShrinkToFit "0") - (Shade "0") - (Rotation "0") - (PatternColor "0:0:0") - (Locked "1") - (Indent "0") - (Hidden "0") - (HAlign "1") - (Format "General") - (Fore "0:0:0") - (Back "FFFF:FFFF:FFFF")) - (http://www.gnumeric.org/v10.dtd:Font - (@ (Unit "10") - (Underline "0") - (StrikeThrough "0") - (Script "0") - (Italic "0") - (Bold "0")) - "Sans")))) - (http://www.gnumeric.org/v10.dtd:Cols (@ (DefaultSizePts "48"))) - (http://www.gnumeric.org/v10.dtd:Rows - (@ (DefaultSizePts "12.75"))) - (http://www.gnumeric.org/v10.dtd:Selections - (@ (CursorRow "0") (CursorCol "0")) - (http://www.gnumeric.org/v10.dtd:Selection - (@ (startRow "0") (startCol "0") (endRow "0") (endCol "0")))) - (http://www.gnumeric.org/v10.dtd:Cells) - (http://www.gnumeric.org/v10.dtd:SheetLayout (@ (TopLeft "A1"))) - (http://www.gnumeric.org/v10.dtd:Solver - (@ (ProgramR "0") - (ProblemType "0") - (NonNeg "1") - (ModelType "0") - (MaxTime "60") - (MaxIter "1000") - (Discr "0") - (AutoScale "0"))))) - (http://www.gnumeric.org/v10.dtd:UIData (@ (SelectedTab "0")))))) - -(define sheet-meta - '(http://www.gnumeric.org/v10.dtd:Sheet - (@ (Visibility "GNM_SHEET_VISIBILITY_VISIBLE") - (OutlineSymbolsRight "1") - (OutlineSymbolsBelow "1") - (HideZero "0") - (HideRowHeader "0") - (HideGrid "0") - (HideColHeader "0") - (GridColor "0:0:0") - (DisplayOutlines "1") - (DisplayFormulas "0")) - (http://www.gnumeric.org/v10.dtd:MaxCol "8") - (http://www.gnumeric.org/v10.dtd:MaxRow "18") - (http://www.gnumeric.org/v10.dtd:Zoom "1") - (http://www.gnumeric.org/v10.dtd:Names - (http://www.gnumeric.org/v10.dtd:Name - (http://www.gnumeric.org/v10.dtd:name "Print_Area") - (http://www.gnumeric.org/v10.dtd:value "#REF!") - (http://www.gnumeric.org/v10.dtd:position "A1")) - (http://www.gnumeric.org/v10.dtd:Name - (http://www.gnumeric.org/v10.dtd:name "Sheet_Title") - (http://www.gnumeric.org/v10.dtd:value "\"First_Sheet\"") - (http://www.gnumeric.org/v10.dtd:position "A1"))) - (http://www.gnumeric.org/v10.dtd:PrintInformation - (http://www.gnumeric.org/v10.dtd:Margins - (http://www.gnumeric.org/v10.dtd:top - (@ (PrefUnit "mm") (Points "93.26"))) - (http://www.gnumeric.org/v10.dtd:bottom - (@ (PrefUnit "mm") (Points "93.26"))) - (http://www.gnumeric.org/v10.dtd:left (@ (PrefUnit "mm") (Points "72"))) - (http://www.gnumeric.org/v10.dtd:right (@ (PrefUnit "mm") (Points "72"))) - (http://www.gnumeric.org/v10.dtd:header - (@ (PrefUnit "mm") (Points "72"))) - (http://www.gnumeric.org/v10.dtd:footer - (@ (PrefUnit "mm") (Points "72")))) - (http://www.gnumeric.org/v10.dtd:Scale - (@ (type "percentage") (percentage "100"))) - (http://www.gnumeric.org/v10.dtd:vcenter (@ (value "0"))) - (http://www.gnumeric.org/v10.dtd:hcenter (@ (value "0"))) - (http://www.gnumeric.org/v10.dtd:grid (@ (value "0"))) - (http://www.gnumeric.org/v10.dtd:even_if_only_styles (@ (value "0"))) - (http://www.gnumeric.org/v10.dtd:monochrome (@ (value "0"))) - (http://www.gnumeric.org/v10.dtd:draft (@ (value "0"))) - (http://www.gnumeric.org/v10.dtd:titles (@ (value "0"))) - (http://www.gnumeric.org/v10.dtd:do_not_print (@ (value "0"))) - (http://www.gnumeric.org/v10.dtd:print_range (@ (value "0"))) - (http://www.gnumeric.org/v10.dtd:order "d_then_r") - (http://www.gnumeric.org/v10.dtd:orientation "portrait") - (http://www.gnumeric.org/v10.dtd:Header - (@ (Right "") (Middle "&[tab]") (Left ""))) - (http://www.gnumeric.org/v10.dtd:Footer - (@ (Right "") (Middle "&[page]") (Left ""))) - (http://www.gnumeric.org/v10.dtd:paper "na_letter") - (http://www.gnumeric.org/v10.dtd:comments "in_place") - (http://www.gnumeric.org/v10.dtd:errors "as_displayed")) - (http://www.gnumeric.org/v10.dtd:Styles - (http://www.gnumeric.org/v10.dtd:StyleRegion - (@ (startRow "0") (startCol "0") (endRow "0") (endCol "1")) - (http://www.gnumeric.org/v10.dtd:Style - (@ (WrapText "0") - (VAlign "2") - (ShrinkToFit "0") - (Shade "0") - (Rotation "0") - (PatternColor "0:0:0") - (Locked "1") - (Indent "0") - (Hidden "0") - (HAlign "1") - (Format "General") - (Fore "0:0:0") - (Back "FFFF:FFFF:FFFF")) - (http://www.gnumeric.org/v10.dtd:Font - (@ (Unit "10") - (Underline "0") - (StrikeThrough "0") - (Script "0") - (Italic "0") - (Bold "0")) - "Sans"))) - (http://www.gnumeric.org/v10.dtd:StyleRegion - (@ (startRow "1") (startCol "0") (endRow "17") (endCol "1")) - (http://www.gnumeric.org/v10.dtd:Style - (@ (WrapText "0") - (VAlign "2") - (ShrinkToFit "0") - (Shade "0") - (Rotation "0") - (PatternColor "0:0:0") - (Locked "1") - (Indent "0") - (Hidden "0") - (HAlign "1") - (Format "hh\":\"mm\":\"ss AM/PM") - (Fore "0:0:0") - (Back "FFFF:FFFF:FFFF")) - (http://www.gnumeric.org/v10.dtd:Font - (@ (Unit "10") - (Underline "0") - (StrikeThrough "0") - (Script "0") - (Italic "0") - (Bold "0")) - "Sans"))) - (http://www.gnumeric.org/v10.dtd:StyleRegion - (@ (startRow "18") (startCol "0") (endRow "31") (endCol "2")) - (http://www.gnumeric.org/v10.dtd:Style - (@ (WrapText "0") - (VAlign "2") - (ShrinkToFit "0") - (Shade "0") - (Rotation "0") - (PatternColor "0:0:0") - (Locked "1") - (Indent "0") - (Hidden "0") - (HAlign "1") - (Format "General") - (Fore "0:0:0") - (Back "FFFF:FFFF:FFFF")) - (http://www.gnumeric.org/v10.dtd:Font - (@ (Unit "10") - (Underline "0") - (StrikeThrough "0") - (Script "0") - (Italic "0") - (Bold "0")) - "Sans"))) - (http://www.gnumeric.org/v10.dtd:StyleRegion - (@ (startRow "32") (startCol "0") (endRow "255") (endCol "7")) - (http://www.gnumeric.org/v10.dtd:Style - (@ (WrapText "0") - (VAlign "2") - (ShrinkToFit "0") - (Shade "0") - (Rotation "0") - (PatternColor "0:0:0") - (Locked "1") - (Indent "0") - (Hidden "0") - (HAlign "1") - (Format "General") - (Fore "0:0:0") - (Back "FFFF:FFFF:FFFF")) - (http://www.gnumeric.org/v10.dtd:Font - (@ (Unit "10") - (Underline "0") - (StrikeThrough "0") - (Script "0") - (Italic "0") - (Bold "0")) - "Sans"))) - (http://www.gnumeric.org/v10.dtd:StyleRegion - (@ (startRow "256") (startCol "0") (endRow "65535") (endCol "63")) - (http://www.gnumeric.org/v10.dtd:Style - (@ (WrapText "0") - (VAlign "2") - (ShrinkToFit "0") - (Shade "0") - (Rotation "0") - (PatternColor "0:0:0") - (Locked "1") - (Indent "0") - (Hidden "0") - (HAlign "1") - (Format "General") - (Fore "0:0:0") - (Back "FFFF:FFFF:FFFF")) - (http://www.gnumeric.org/v10.dtd:Font - (@ (Unit "10") - (Underline "0") - (StrikeThrough "0") - (Script "0") - (Italic "0") - (Bold "0")) - "Sans"))) - (http://www.gnumeric.org/v10.dtd:StyleRegion - (@ (startRow "0") (startCol "2") (endRow "1") (endCol "2")) - (http://www.gnumeric.org/v10.dtd:Style - (@ (WrapText "0") - (VAlign "2") - (ShrinkToFit "0") - (Shade "0") - (Rotation "0") - (PatternColor "0:0:0") - (Locked "1") - (Indent "0") - (Hidden "0") - (HAlign "1") - (Format "General") - (Fore "0:0:0") - (Back "FFFF:FFFF:FFFF")) - (http://www.gnumeric.org/v10.dtd:Font - (@ (Unit "10") - (Underline "0") - (StrikeThrough "0") - (Script "0") - (Italic "0") - (Bold "0")) - "Sans"))) - (http://www.gnumeric.org/v10.dtd:StyleRegion - (@ (startRow "2") (startCol "2") (endRow "17") (endCol "2")) - (http://www.gnumeric.org/v10.dtd:Style - (@ (WrapText "0") - (VAlign "2") - (ShrinkToFit "0") - (Shade "0") - (Rotation "0") - (PatternColor "0:0:0") - (Locked "1") - (Indent "0") - (Hidden "0") - (HAlign "1") - (Format "0") - (Fore "0:0:0") - (Back "FFFF:FFFF:FFFF")) - (http://www.gnumeric.org/v10.dtd:Font - (@ (Unit "10") - (Underline "0") - (StrikeThrough "0") - (Script "0") - (Italic "0") - (Bold "0")) - "Sans"))) - (http://www.gnumeric.org/v10.dtd:StyleRegion - (@ (startRow "0") (startCol "3") (endRow "31") (endCol "7")) - (http://www.gnumeric.org/v10.dtd:Style - (@ (WrapText "0") - (VAlign "2") - (ShrinkToFit "0") - (Shade "0") - (Rotation "0") - (PatternColor "0:0:0") - (Locked "1") - (Indent "0") - (Hidden "0") - (HAlign "1") - (Format "General") - (Fore "0:0:0") - (Back "FFFF:FFFF:FFFF")) - (http://www.gnumeric.org/v10.dtd:Font - (@ (Unit "10") - (Underline "0") - (StrikeThrough "0") - (Script "0") - (Italic "0") - (Bold "0")) - "Sans"))) - (http://www.gnumeric.org/v10.dtd:StyleRegion - (@ (startRow "0") (startCol "8") (endRow "255") (endCol "63")) - (http://www.gnumeric.org/v10.dtd:Style - (@ (WrapText "0") - (VAlign "2") - (ShrinkToFit "0") - (Shade "0") - (Rotation "0") - (PatternColor "0:0:0") - (Locked "1") - (Indent "0") - (Hidden "0") - (HAlign "1") - (Format "General") - (Fore "0:0:0") - (Back "FFFF:FFFF:FFFF")) - (http://www.gnumeric.org/v10.dtd:Font - (@ (Unit "10") - (Underline "0") - (StrikeThrough "0") - (Script "0") - (Italic "0") - (Bold "0")) - "Sans"))) - (http://www.gnumeric.org/v10.dtd:StyleRegion - (@ (startRow "0") (startCol "64") (endRow "65535") (endCol "255")) - (http://www.gnumeric.org/v10.dtd:Style - (@ (WrapText "0") - (VAlign "2") - (ShrinkToFit "0") - (Shade "0") - (Rotation "0") - (PatternColor "0:0:0") - (Locked "1") - (Indent "0") - (Hidden "0") - (HAlign "1") - (Format "General") - (Fore "0:0:0") - (Back "FFFF:FFFF:FFFF")) - (http://www.gnumeric.org/v10.dtd:Font - (@ (Unit "10") - (Underline "0") - (StrikeThrough "0") - (Script "0") - (Italic "0") - (Bold "0")) - "Sans")))) - (http://www.gnumeric.org/v10.dtd:Cols - (@ (DefaultSizePts "48")) - (http://www.gnumeric.org/v10.dtd:ColInfo (@ (Unit "48") (No "0"))) - (http://www.gnumeric.org/v10.dtd:ColInfo - (@ (Unit "99") (No "1") (HardSize "1"))) - (http://www.gnumeric.org/v10.dtd:ColInfo - (@ (Unit "64.01") (No "2") (Count "7")))) - (http://www.gnumeric.org/v10.dtd:Rows - (@ (DefaultSizePts "12.1")) - (http://www.gnumeric.org/v10.dtd:RowInfo (@ (Unit "12.64") (No "0"))) - (http://www.gnumeric.org/v10.dtd:RowInfo - (@ (Unit "13.5") (No "1") (Count "17"))) - (http://www.gnumeric.org/v10.dtd:RowInfo (@ (Unit "12.1") (No "18")))) - (http://www.gnumeric.org/v10.dtd:Selections - (@ (CursorRow "3") (CursorCol "1")) - (http://www.gnumeric.org/v10.dtd:Selection - (@ (startRow "3") (startCol "1") (endRow "3") (endCol "1")))) - (http://www.gnumeric.org/v10.dtd:SheetLayout - (@ (TopLeft "A2")) - (http://www.gnumeric.org/v10.dtd:FreezePanes - (@ (UnfrozenTopLeft "A2") (FrozenTopLeft "A1")))) - (http://www.gnumeric.org/v10.dtd:Solver - (@ (ProgramR "0") - (ProblemType "0") - (NonNeg "1") - (ModelType "0") - (MaxTime "60") - (MaxIter "1000") - (Discr "0") - (AutoScale "0"))))) - -(define sheets-meta - '((@ (http://www.w3.org/2001/XMLSchema-instance:schemaLocation - "http://www.gnumeric.org/v9.xsd")) - (http://www.gnumeric.org/v10.dtd:Version - (@ (Minor "17") (Major "10") (Full "1.10.17") (Epoch "1"))) - (http://www.gnumeric.org/v10.dtd:Attributes - (http://www.gnumeric.org/v10.dtd:Attribute - (http://www.gnumeric.org/v10.dtd:type "4") - (http://www.gnumeric.org/v10.dtd:name - "WorkbookView::show_horizontal_scrollbar") - (http://www.gnumeric.org/v10.dtd:value "TRUE")) - (http://www.gnumeric.org/v10.dtd:Attribute - (http://www.gnumeric.org/v10.dtd:type "4") - (http://www.gnumeric.org/v10.dtd:name - "WorkbookView::show_vertical_scrollbar") - (http://www.gnumeric.org/v10.dtd:value "TRUE")) - (http://www.gnumeric.org/v10.dtd:Attribute - (http://www.gnumeric.org/v10.dtd:type "4") - (http://www.gnumeric.org/v10.dtd:name "WorkbookView::show_notebook_tabs") - (http://www.gnumeric.org/v10.dtd:value "TRUE")) - (http://www.gnumeric.org/v10.dtd:Attribute - (http://www.gnumeric.org/v10.dtd:type "4") - (http://www.gnumeric.org/v10.dtd:name "WorkbookView::do_auto_completion") - (http://www.gnumeric.org/v10.dtd:value "TRUE")) - (http://www.gnumeric.org/v10.dtd:Attribute - (http://www.gnumeric.org/v10.dtd:type "4") - (http://www.gnumeric.org/v10.dtd:name "WorkbookView::is_protected") - (http://www.gnumeric.org/v10.dtd:value "FALSE"))) - (urn:oasis:names:tc:opendocument:xmlns:office:1.0:document-meta - (@ (urn:oasis:names:tc:opendocument:xmlns:office:1.0:version "1.2")) - (urn:oasis:names:tc:opendocument:xmlns:office:1.0:meta - (http://purl.org/dc/elements/1.1/:date "2013-07-26T04:47:02Z") - (urn:oasis:names:tc:opendocument:xmlns:meta:1.0:creation-date - "2013-07-26T04:46:14Z"))) - (http://www.gnumeric.org/v10.dtd:Calculation - (@ (MaxIterations "100") - (ManualRecalc "0") - (IterationTolerance "0.001") - (FloatRadix "2") - (FloatDigits "53") - (EnableIteration "1"))) - (http://www.gnumeric.org/v10.dtd:SheetNameIndex - (http://www.gnumeric.org/v10.dtd:SheetName - (@ (http://www.gnumeric.org/v10.dtd:Rows "65536") - (http://www.gnumeric.org/v10.dtd:Cols "256")) - "First_Sheet") - (http://www.gnumeric.org/v10.dtd:SheetName - (@ (http://www.gnumeric.org/v10.dtd:Rows "65536") - (http://www.gnumeric.org/v10.dtd:Cols "256")) - "Second-sheet") - (http://www.gnumeric.org/v10.dtd:SheetName - (@ (http://www.gnumeric.org/v10.dtd:Rows "65536") - (http://www.gnumeric.org/v10.dtd:Cols "256")) - "RunsToDo") - (http://www.gnumeric.org/v10.dtd:SheetName - (@ (http://www.gnumeric.org/v10.dtd:Rows "65536") - (http://www.gnumeric.org/v10.dtd:Cols "256")) - "RunsToLock")) - (http://www.gnumeric.org/v10.dtd:Geometry (@ (Width "1440") (Height "647"))) - (http://www.gnumeric.org/v10.dtd:UIData (@ (SelectedTab "1"))))) - -(define workbook-meta - '(*TOP* (*PI* xml "version=\"1.0\" encoding=\"UTF-8\""))) - DELETED txtdb/nada3/First_Sheet.dat Index: txtdb/nada3/First_Sheet.dat ================================================================== --- txtdb/nada3/First_Sheet.dat +++ /dev/null @@ -1,153 +0,0 @@ -[Time] -BLANKVAL -A 0.324305555555556 -B 0.33125 -C 0.334722222222222 -D 0.336805555555556 -E 0.338888888888889 -F 0.340972222222222 -G 0.343055555555556 -H 0.345833333333333 -I 0.347916666666667 -J 0.351388888888889 -K 0.366666666666667 -L 0.379166666666667 -M 0.395833333333333 -N 0.422222222222222 -O 0.452083333333333 -P 0.491666666666667 -Q 0.570833333333333 - -[DeltaTime] -A 0 -B =days(B3,$B$2)*24*60 -C -D -E -F -G -H -I -J -K -L -M -N -O -P -Q - -[Ambient] -A 35.4 -B 35.4 -C 35 -D 35 -E 35 -F 35 -G 35 -H 36 -I 36 -J 37 -K 37 -L 38 -M 39 -N 40 -O 41 -P 41 -Q 41.5 - -[Firebox] -A 34.3 -B 72 -C 100 -D 130 -E 145 -F 150 -G 150 -H 158 -I 156 -J 152 -K 134 -L 117 -M 100 -N 91 -O 79 -P 68 -Q 51 - -[2nd_row] -A 34.3 -B 60 -C 90 -D 116 -E 121 -F 125 -G 128 -H 129 -I 128 -J 126 -K 117 -L 108 -M 100 -N 90 -O 78 -P 63 -Q 51 - -[3rd_row] -A 34.1 -B 42 -C 57 -D 69 -E 73 -F 78 -G 82 -H 86 -I 87 -J 89 -K 94 -L 96 -M 93 -N 88 -O 77 -P 64 -Q 51 - -[4th_row] -A 34 -B 39 -C 46 -D 52 -E 54 -F 56 -G 60 -H 62 -I 65 -J 67 -K 77 -L 82 -M 82 -N 81 -O 72 -P 62 -Q 51 - -[Exit] -A 34 -B 68 -C 68 -D 68 -E 68 -F 68 -G 69 -H 70 -I 72 -J 75 -K 107 -L 106 -M 106 -N 100 -O 79 -P 68 -Q 51 - DELETED txtdb/nada3/RunsToDo.dat Index: txtdb/nada3/RunsToDo.dat ================================================================== --- txtdb/nada3/RunsToDo.dat +++ /dev/null @@ -1,15 +0,0 @@ -[a/b/c] -123 a -456 b -789 c - -[d/e/f] -123 e -456 f -789 g - -[g/h/i] -123 h -456 i -789 j - DELETED txtdb/nada3/RunsToLock.dat Index: txtdb/nada3/RunsToLock.dat ================================================================== --- txtdb/nada3/RunsToLock.dat +++ /dev/null @@ -1,12 +0,0 @@ -[def] -def def -ghi jkl -qrst -uvwx -yz12 - -[mno] -abc -def xyz -jkl -mnop DELETED txtdb/nada3/Second-sheet.dat Index: txtdb/nada3/Second-sheet.dat ================================================================== --- txtdb/nada3/Second-sheet.dat +++ /dev/null @@ -1,34 +0,0 @@ -[2] -V2 X -V6 Y -V8 Z -V12 E -V15 B -V17 + - -[A1] -V8 Z -V17 = - -# Just a test really -# -V1 X -V3 X -V5 Y -V7 Y -V10 Z -V11 E -V13 E -V14 B -V16 B -[3] -V2 John, -V6 Tom -V8 Fred -V17 ~ - -# a deeply held belief is a danger to sanity -# -V4 X -row-11 Z -row-18 B DELETED txtdb/nada3/Sheet3.dat Index: txtdb/nada3/Sheet3.dat ================================================================== --- txtdb/nada3/Sheet3.dat +++ /dev/null @@ -1,8 +0,0 @@ -[zeroth title] -row1name -row2name - -[col1title] -row1name row1value -row2nameNoValue -row3name row3value DELETED txtdb/nada3/sheet-names.cfg Index: txtdb/nada3/sheet-names.cfg ================================================================== --- txtdb/nada3/sheet-names.cfg +++ /dev/null @@ -1,4 +0,0 @@ -First_Sheet -Second-sheet -RunsToDo -RunsToLock DELETED txtdb/nada3/sxml/First_Sheet.sxml Index: txtdb/nada3/sxml/First_Sheet.sxml ================================================================== --- txtdb/nada3/sxml/First_Sheet.sxml +++ /dev/null @@ -1,460 +0,0 @@ -(http://www.gnumeric.org/v10.dtd:Sheet - (@ (Visibility "GNM_SHEET_VISIBILITY_VISIBLE") - (OutlineSymbolsRight "1") - (OutlineSymbolsBelow "1") - (HideZero "0") - (HideRowHeader "0") - (HideGrid "0") - (HideColHeader "0") - (DisplayOutlines "1") - (DisplayFormulas "0")) - (http://www.gnumeric.org/v10.dtd:MaxCol "8") - (http://www.gnumeric.org/v10.dtd:MaxRow "19") - (http://www.gnumeric.org/v10.dtd:Zoom "1") - (http://www.gnumeric.org/v10.dtd:Names - (http://www.gnumeric.org/v10.dtd:Name - (http://www.gnumeric.org/v10.dtd:name "Sheet_Title") - (http://www.gnumeric.org/v10.dtd:value "\"First_Sheet\"") - (http://www.gnumeric.org/v10.dtd:position "A1")) - (http://www.gnumeric.org/v10.dtd:Name - (http://www.gnumeric.org/v10.dtd:name "Print_Area") - (http://www.gnumeric.org/v10.dtd:value "#REF!") - (http://www.gnumeric.org/v10.dtd:position "A1"))) - (http://www.gnumeric.org/v10.dtd:PrintInformation - (http://www.gnumeric.org/v10.dtd:Margins - (http://www.gnumeric.org/v10.dtd:top - (@ (PrefUnit "mm") (Points "93.26"))) - (http://www.gnumeric.org/v10.dtd:bottom - (@ (PrefUnit "mm") (Points "93.26"))) - (http://www.gnumeric.org/v10.dtd:left (@ (PrefUnit "Pt") (Points "72"))) - (http://www.gnumeric.org/v10.dtd:right (@ (PrefUnit "Pt") (Points "72"))) - (http://www.gnumeric.org/v10.dtd:header - (@ (PrefUnit "Pt") (Points "72"))) - (http://www.gnumeric.org/v10.dtd:footer - (@ (PrefUnit "Pt") (Points "72")))) - (http://www.gnumeric.org/v10.dtd:Scale - (@ (type "percentage") (percentage "100"))) - (http://www.gnumeric.org/v10.dtd:vcenter (@ (value "0"))) - (http://www.gnumeric.org/v10.dtd:hcenter (@ (value "0"))) - (http://www.gnumeric.org/v10.dtd:grid (@ (value "0"))) - (http://www.gnumeric.org/v10.dtd:even_if_only_styles (@ (value "0"))) - (http://www.gnumeric.org/v10.dtd:monochrome (@ (value "0"))) - (http://www.gnumeric.org/v10.dtd:draft (@ (value "0"))) - (http://www.gnumeric.org/v10.dtd:titles (@ (value "0"))) - (http://www.gnumeric.org/v10.dtd:order "d_then_r") - (http://www.gnumeric.org/v10.dtd:orientation "portrait") - (http://www.gnumeric.org/v10.dtd:Header - (@ (Right "") (Middle "&[tab]") (Left ""))) - (http://www.gnumeric.org/v10.dtd:Footer - (@ (Right "") (Middle "&[page]") (Left ""))) - (http://www.gnumeric.org/v10.dtd:paper "na_letter")) - (http://www.gnumeric.org/v10.dtd:Styles - (http://www.gnumeric.org/v10.dtd:StyleRegion - (@ (startRow "4096") (startCol "0") (endRow "65535") (endCol "63")) - (http://www.gnumeric.org/v10.dtd:Style - (@ (WrapText "0") - (VAlign "2") - (ShrinkToFit "0") - (Shade "0") - (Rotation "0") - (PatternColor "0:0:0") - (Locked "1") - (Indent "0") - (Hidden "0") - (HAlign "1") - (Format "General") - (Fore "0:0:0") - (Back "FFFF:FFFF:FFFF")) - (http://www.gnumeric.org/v10.dtd:Font - (@ (Unit "10") - (Underline "0") - (StrikeThrough "0") - (Script "0") - (Italic "0") - (Bold "0")) - "Sans") - (http://www.gnumeric.org/v10.dtd:StyleBorder - (http://www.gnumeric.org/v10.dtd:Top (@ (Style "0"))) - (http://www.gnumeric.org/v10.dtd:Bottom (@ (Style "0"))) - (http://www.gnumeric.org/v10.dtd:Left (@ (Style "0"))) - (http://www.gnumeric.org/v10.dtd:Right (@ (Style "0"))) - (http://www.gnumeric.org/v10.dtd:Diagonal (@ (Style "0"))) - (http://www.gnumeric.org/v10.dtd:Rev-Diagonal (@ (Style "0")))))) - (http://www.gnumeric.org/v10.dtd:StyleRegion - (@ (startRow "0") (startCol "4") (endRow "255") (endCol "15")) - (http://www.gnumeric.org/v10.dtd:Style - (@ (WrapText "0") - (VAlign "2") - (ShrinkToFit "0") - (Shade "0") - (Rotation "0") - (PatternColor "0:0:0") - (Locked "1") - (Indent "0") - (Hidden "0") - (HAlign "1") - (Format "General") - (Fore "0:0:0") - (Back "FFFF:FFFF:FFFF")) - (http://www.gnumeric.org/v10.dtd:Font - (@ (Unit "10") - (Underline "0") - (StrikeThrough "0") - (Script "0") - (Italic "0") - (Bold "0")) - "Sans") - (http://www.gnumeric.org/v10.dtd:StyleBorder - (http://www.gnumeric.org/v10.dtd:Top (@ (Style "0"))) - (http://www.gnumeric.org/v10.dtd:Bottom (@ (Style "0"))) - (http://www.gnumeric.org/v10.dtd:Left (@ (Style "0"))) - (http://www.gnumeric.org/v10.dtd:Right (@ (Style "0"))) - (http://www.gnumeric.org/v10.dtd:Diagonal (@ (Style "0"))) - (http://www.gnumeric.org/v10.dtd:Rev-Diagonal (@ (Style "0")))))) - (http://www.gnumeric.org/v10.dtd:StyleRegion - (@ (startRow "32") (startCol "0") (endRow "255") (endCol "3")) - (http://www.gnumeric.org/v10.dtd:Style - (@ (WrapText "0") - (VAlign "2") - (ShrinkToFit "0") - (Shade "0") - (Rotation "0") - (PatternColor "0:0:0") - (Locked "1") - (Indent "0") - (Hidden "0") - (HAlign "1") - (Format "General") - (Fore "0:0:0") - (Back "FFFF:FFFF:FFFF")) - (http://www.gnumeric.org/v10.dtd:Font - (@ (Unit "10") - (Underline "0") - (StrikeThrough "0") - (Script "0") - (Italic "0") - (Bold "0")) - "Sans") - (http://www.gnumeric.org/v10.dtd:StyleBorder - (http://www.gnumeric.org/v10.dtd:Top (@ (Style "0"))) - (http://www.gnumeric.org/v10.dtd:Bottom (@ (Style "0"))) - (http://www.gnumeric.org/v10.dtd:Left (@ (Style "0"))) - (http://www.gnumeric.org/v10.dtd:Right (@ (Style "0"))) - (http://www.gnumeric.org/v10.dtd:Diagonal (@ (Style "0"))) - (http://www.gnumeric.org/v10.dtd:Rev-Diagonal (@ (Style "0")))))) - (http://www.gnumeric.org/v10.dtd:StyleRegion - (@ (startRow "2") (startCol "2") (endRow "17") (endCol "2")) - (http://www.gnumeric.org/v10.dtd:Style - (@ (WrapText "0") - (VAlign "2") - (ShrinkToFit "0") - (Shade "0") - (Rotation "0") - (PatternColor "0:0:0") - (Locked "1") - (Indent "0") - (Hidden "0") - (HAlign "1") - (Format "0") - (Fore "0:0:0") - (Back "FFFF:FFFF:FFFF")) - (http://www.gnumeric.org/v10.dtd:Font - (@ (Unit "10") - (Underline "0") - (StrikeThrough "0") - (Script "0") - (Italic "0") - (Bold "0")) - "Sans") - (http://www.gnumeric.org/v10.dtd:StyleBorder - (http://www.gnumeric.org/v10.dtd:Top (@ (Style "0"))) - (http://www.gnumeric.org/v10.dtd:Bottom (@ (Style "0"))) - (http://www.gnumeric.org/v10.dtd:Left (@ (Style "0"))) - (http://www.gnumeric.org/v10.dtd:Right (@ (Style "0"))) - (http://www.gnumeric.org/v10.dtd:Diagonal (@ (Style "0"))) - (http://www.gnumeric.org/v10.dtd:Rev-Diagonal (@ (Style "0")))))) - (http://www.gnumeric.org/v10.dtd:StyleRegion - (@ (startRow "0") (startCol "3") (endRow "31") (endCol "3")) - (http://www.gnumeric.org/v10.dtd:Style - (@ (WrapText "0") - (VAlign "2") - (ShrinkToFit "0") - (Shade "0") - (Rotation "0") - (PatternColor "0:0:0") - (Locked "1") - (Indent "0") - (Hidden "0") - (HAlign "1") - (Format "General") - (Fore "0:0:0") - (Back "FFFF:FFFF:FFFF")) - (http://www.gnumeric.org/v10.dtd:Font - (@ (Unit "10") - (Underline "0") - (StrikeThrough "0") - (Script "0") - (Italic "0") - (Bold "0")) - "Sans") - (http://www.gnumeric.org/v10.dtd:StyleBorder - (http://www.gnumeric.org/v10.dtd:Top (@ (Style "0"))) - (http://www.gnumeric.org/v10.dtd:Bottom (@ (Style "0"))) - (http://www.gnumeric.org/v10.dtd:Left (@ (Style "0"))) - (http://www.gnumeric.org/v10.dtd:Right (@ (Style "0"))) - (http://www.gnumeric.org/v10.dtd:Diagonal (@ (Style "0"))) - (http://www.gnumeric.org/v10.dtd:Rev-Diagonal (@ (Style "0")))))) - (http://www.gnumeric.org/v10.dtd:StyleRegion - (@ (startRow "1") (startCol "0") (endRow "17") (endCol "1")) - (http://www.gnumeric.org/v10.dtd:Style - (@ (WrapText "0") - (VAlign "2") - (ShrinkToFit "0") - (Shade "0") - (Rotation "0") - (PatternColor "0:0:0") - (Locked "1") - (Indent "0") - (Hidden "0") - (HAlign "1") - (Format "hh\":\"mm\":\"ss AM/PM") - (Fore "0:0:0") - (Back "FFFF:FFFF:FFFF")) - (http://www.gnumeric.org/v10.dtd:Font - (@ (Unit "10") - (Underline "0") - (StrikeThrough "0") - (Script "0") - (Italic "0") - (Bold "0")) - "Sans") - (http://www.gnumeric.org/v10.dtd:StyleBorder - (http://www.gnumeric.org/v10.dtd:Top (@ (Style "0"))) - (http://www.gnumeric.org/v10.dtd:Bottom (@ (Style "0"))) - (http://www.gnumeric.org/v10.dtd:Left (@ (Style "0"))) - (http://www.gnumeric.org/v10.dtd:Right (@ (Style "0"))) - (http://www.gnumeric.org/v10.dtd:Diagonal (@ (Style "0"))) - (http://www.gnumeric.org/v10.dtd:Rev-Diagonal (@ (Style "0")))))) - (http://www.gnumeric.org/v10.dtd:StyleRegion - (@ (startRow "18") (startCol "0") (endRow "31") (endCol "2")) - (http://www.gnumeric.org/v10.dtd:Style - (@ (WrapText "0") - (VAlign "2") - (ShrinkToFit "0") - (Shade "0") - (Rotation "0") - (PatternColor "0:0:0") - (Locked "1") - (Indent "0") - (Hidden "0") - (HAlign "1") - (Format "General") - (Fore "0:0:0") - (Back "FFFF:FFFF:FFFF")) - (http://www.gnumeric.org/v10.dtd:Font - (@ (Unit "10") - (Underline "0") - (StrikeThrough "0") - (Script "0") - (Italic "0") - (Bold "0")) - "Sans") - (http://www.gnumeric.org/v10.dtd:StyleBorder - (http://www.gnumeric.org/v10.dtd:Top (@ (Style "0"))) - (http://www.gnumeric.org/v10.dtd:Bottom (@ (Style "0"))) - (http://www.gnumeric.org/v10.dtd:Left (@ (Style "0"))) - (http://www.gnumeric.org/v10.dtd:Right (@ (Style "0"))) - (http://www.gnumeric.org/v10.dtd:Diagonal (@ (Style "0"))) - (http://www.gnumeric.org/v10.dtd:Rev-Diagonal (@ (Style "0")))))) - (http://www.gnumeric.org/v10.dtd:StyleRegion - (@ (startRow "0") (startCol "16") (endRow "4095") (endCol "63")) - (http://www.gnumeric.org/v10.dtd:Style - (@ (WrapText "0") - (VAlign "2") - (ShrinkToFit "0") - (Shade "0") - (Rotation "0") - (PatternColor "0:0:0") - (Locked "1") - (Indent "0") - (Hidden "0") - (HAlign "1") - (Format "General") - (Fore "0:0:0") - (Back "FFFF:FFFF:FFFF")) - (http://www.gnumeric.org/v10.dtd:Font - (@ (Unit "10") - (Underline "0") - (StrikeThrough "0") - (Script "0") - (Italic "0") - (Bold "0")) - "Sans") - (http://www.gnumeric.org/v10.dtd:StyleBorder - (http://www.gnumeric.org/v10.dtd:Top (@ (Style "0"))) - (http://www.gnumeric.org/v10.dtd:Bottom (@ (Style "0"))) - (http://www.gnumeric.org/v10.dtd:Left (@ (Style "0"))) - (http://www.gnumeric.org/v10.dtd:Right (@ (Style "0"))) - (http://www.gnumeric.org/v10.dtd:Diagonal (@ (Style "0"))) - (http://www.gnumeric.org/v10.dtd:Rev-Diagonal (@ (Style "0")))))) - (http://www.gnumeric.org/v10.dtd:StyleRegion - (@ (startRow "0") (startCol "2") (endRow "1") (endCol "2")) - (http://www.gnumeric.org/v10.dtd:Style - (@ (WrapText "0") - (VAlign "2") - (ShrinkToFit "0") - (Shade "0") - (Rotation "0") - (PatternColor "0:0:0") - (Locked "1") - (Indent "0") - (Hidden "0") - (HAlign "1") - (Format "General") - (Fore "0:0:0") - (Back "FFFF:FFFF:FFFF")) - (http://www.gnumeric.org/v10.dtd:Font - (@ (Unit "10") - (Underline "0") - (StrikeThrough "0") - (Script "0") - (Italic "0") - (Bold "0")) - "Sans") - (http://www.gnumeric.org/v10.dtd:StyleBorder - (http://www.gnumeric.org/v10.dtd:Top (@ (Style "0"))) - (http://www.gnumeric.org/v10.dtd:Bottom (@ (Style "0"))) - (http://www.gnumeric.org/v10.dtd:Left (@ (Style "0"))) - (http://www.gnumeric.org/v10.dtd:Right (@ (Style "0"))) - (http://www.gnumeric.org/v10.dtd:Diagonal (@ (Style "0"))) - (http://www.gnumeric.org/v10.dtd:Rev-Diagonal (@ (Style "0")))))) - (http://www.gnumeric.org/v10.dtd:StyleRegion - (@ (startRow "0") (startCol "64") (endRow "65535") (endCol "255")) - (http://www.gnumeric.org/v10.dtd:Style - (@ (WrapText "0") - (VAlign "2") - (ShrinkToFit "0") - (Shade "0") - (Rotation "0") - (PatternColor "0:0:0") - (Locked "1") - (Indent "0") - (Hidden "0") - (HAlign "1") - (Format "General") - (Fore "0:0:0") - (Back "FFFF:FFFF:FFFF")) - (http://www.gnumeric.org/v10.dtd:Font - (@ (Unit "10") - (Underline "0") - (StrikeThrough "0") - (Script "0") - (Italic "0") - (Bold "0")) - "Sans") - (http://www.gnumeric.org/v10.dtd:StyleBorder - (http://www.gnumeric.org/v10.dtd:Top (@ (Style "0"))) - (http://www.gnumeric.org/v10.dtd:Bottom (@ (Style "0"))) - (http://www.gnumeric.org/v10.dtd:Left (@ (Style "0"))) - (http://www.gnumeric.org/v10.dtd:Right (@ (Style "0"))) - (http://www.gnumeric.org/v10.dtd:Diagonal (@ (Style "0"))) - (http://www.gnumeric.org/v10.dtd:Rev-Diagonal (@ (Style "0")))))) - (http://www.gnumeric.org/v10.dtd:StyleRegion - (@ (startRow "256") (startCol "0") (endRow "4095") (endCol "15")) - (http://www.gnumeric.org/v10.dtd:Style - (@ (WrapText "0") - (VAlign "2") - (ShrinkToFit "0") - (Shade "0") - (Rotation "0") - (PatternColor "0:0:0") - (Locked "1") - (Indent "0") - (Hidden "0") - (HAlign "1") - (Format "General") - (Fore "0:0:0") - (Back "FFFF:FFFF:FFFF")) - (http://www.gnumeric.org/v10.dtd:Font - (@ (Unit "10") - (Underline "0") - (StrikeThrough "0") - (Script "0") - (Italic "0") - (Bold "0")) - "Sans") - (http://www.gnumeric.org/v10.dtd:StyleBorder - (http://www.gnumeric.org/v10.dtd:Top (@ (Style "0"))) - (http://www.gnumeric.org/v10.dtd:Bottom (@ (Style "0"))) - (http://www.gnumeric.org/v10.dtd:Left (@ (Style "0"))) - (http://www.gnumeric.org/v10.dtd:Right (@ (Style "0"))) - (http://www.gnumeric.org/v10.dtd:Diagonal (@ (Style "0"))) - (http://www.gnumeric.org/v10.dtd:Rev-Diagonal (@ (Style "0")))))) - (http://www.gnumeric.org/v10.dtd:StyleRegion - (@ (startRow "0") (startCol "0") (endRow "0") (endCol "1")) - (http://www.gnumeric.org/v10.dtd:Style - (@ (WrapText "0") - (VAlign "2") - (ShrinkToFit "0") - (Shade "0") - (Rotation "0") - (PatternColor "0:0:0") - (Locked "1") - (Indent "0") - (Hidden "0") - (HAlign "1") - (Format "General") - (Fore "0:0:0") - (Back "FFFF:FFFF:FFFF")) - (http://www.gnumeric.org/v10.dtd:Font - (@ (Unit "10") - (Underline "0") - (StrikeThrough "0") - (Script "0") - (Italic "0") - (Bold "0")) - "Sans") - (http://www.gnumeric.org/v10.dtd:StyleBorder - (http://www.gnumeric.org/v10.dtd:Top (@ (Style "0"))) - (http://www.gnumeric.org/v10.dtd:Bottom (@ (Style "0"))) - (http://www.gnumeric.org/v10.dtd:Left (@ (Style "0"))) - (http://www.gnumeric.org/v10.dtd:Right (@ (Style "0"))) - (http://www.gnumeric.org/v10.dtd:Diagonal (@ (Style "0"))) - (http://www.gnumeric.org/v10.dtd:Rev-Diagonal (@ (Style "0"))))))) - (http://www.gnumeric.org/v10.dtd:Cols - (@ (DefaultSizePts "48")) - (http://www.gnumeric.org/v10.dtd:ColInfo - (@ (Unit "48") (No "0") (MarginB "2") (MarginA "2"))) - (http://www.gnumeric.org/v10.dtd:ColInfo - (@ (Unit "99") (No "1") (MarginB "2") (MarginA "2") (HardSize "1"))) - (http://www.gnumeric.org/v10.dtd:ColInfo - (@ (Unit "64.01") (No "2") (MarginB "2") (MarginA "2") (Count "7")))) - (http://www.gnumeric.org/v10.dtd:Rows - (@ (DefaultSizePts "12.1")) - (http://www.gnumeric.org/v10.dtd:RowInfo - (@ (Unit "12.64") (No "0") (MarginB "0") (MarginA "0"))) - (http://www.gnumeric.org/v10.dtd:RowInfo - (@ (Unit "13.5") (No "1") (MarginB "0") (MarginA "0") (Count "17"))) - (http://www.gnumeric.org/v10.dtd:RowInfo - (@ (Unit "12.1") (No "18") (MarginB "0") (MarginA "0") (Count "2")))) - (http://www.gnumeric.org/v10.dtd:Selections - (@ (CursorRow "3") (CursorCol "1")) - (http://www.gnumeric.org/v10.dtd:Selection - (@ (startRow "3") (startCol "1") (endRow "3") (endCol "1")))) - (http://www.gnumeric.org/v10.dtd:SheetLayout - (@ (TopLeft "A2")) - (http://www.gnumeric.org/v10.dtd:FreezePanes - (@ (UnfrozenTopLeft "A2") (FrozenTopLeft "A1")))) - (http://www.gnumeric.org/v10.dtd:Solver - (@ (ShowIter "0") - (SensitivityR "0") - (ProgramR "0") - (ProblemType "0") - (PerformR "0") - (NonNeg "1") - (MaxTime "60") - (MaxIter "1000") - (LimitsR "0") - (Discr "0") - (AutoScale "0") - (AnswerR "0")))) DELETED txtdb/nada3/sxml/RunsToDo.sxml Index: txtdb/nada3/sxml/RunsToDo.sxml ================================================================== --- txtdb/nada3/sxml/RunsToDo.sxml +++ /dev/null @@ -1,109 +0,0 @@ -(http://www.gnumeric.org/v10.dtd:Sheet - (@ (Visibility "GNM_SHEET_VISIBILITY_VISIBLE") - (OutlineSymbolsRight "1") - (OutlineSymbolsBelow "1") - (HideZero "0") - (HideRowHeader "0") - (HideGrid "0") - (HideColHeader "0") - (DisplayOutlines "1") - (DisplayFormulas "0")) - (http://www.gnumeric.org/v10.dtd:MaxCol "3") - (http://www.gnumeric.org/v10.dtd:MaxRow "4") - (http://www.gnumeric.org/v10.dtd:Zoom "1") - (http://www.gnumeric.org/v10.dtd:Names - (http://www.gnumeric.org/v10.dtd:Name - (http://www.gnumeric.org/v10.dtd:name "Sheet_Title") - (http://www.gnumeric.org/v10.dtd:value "\"RunsToDo\"") - (http://www.gnumeric.org/v10.dtd:position "A1")) - (http://www.gnumeric.org/v10.dtd:Name - (http://www.gnumeric.org/v10.dtd:name "Print_Area") - (http://www.gnumeric.org/v10.dtd:value "#REF!") - (http://www.gnumeric.org/v10.dtd:position "A1"))) - (http://www.gnumeric.org/v10.dtd:PrintInformation - (http://www.gnumeric.org/v10.dtd:Margins - (http://www.gnumeric.org/v10.dtd:top (@ (PrefUnit "mm") (Points "120"))) - (http://www.gnumeric.org/v10.dtd:bottom - (@ (PrefUnit "mm") (Points "120"))) - (http://www.gnumeric.org/v10.dtd:left (@ (PrefUnit "Pt") (Points "72"))) - (http://www.gnumeric.org/v10.dtd:right (@ (PrefUnit "Pt") (Points "72"))) - (http://www.gnumeric.org/v10.dtd:header - (@ (PrefUnit "Pt") (Points "72"))) - (http://www.gnumeric.org/v10.dtd:footer - (@ (PrefUnit "Pt") (Points "72")))) - (http://www.gnumeric.org/v10.dtd:Scale - (@ (type "percentage") (percentage "100"))) - (http://www.gnumeric.org/v10.dtd:vcenter (@ (value "0"))) - (http://www.gnumeric.org/v10.dtd:hcenter (@ (value "0"))) - (http://www.gnumeric.org/v10.dtd:grid (@ (value "0"))) - (http://www.gnumeric.org/v10.dtd:even_if_only_styles (@ (value "0"))) - (http://www.gnumeric.org/v10.dtd:monochrome (@ (value "0"))) - (http://www.gnumeric.org/v10.dtd:draft (@ (value "0"))) - (http://www.gnumeric.org/v10.dtd:titles (@ (value "0"))) - (http://www.gnumeric.org/v10.dtd:order "d_then_r") - (http://www.gnumeric.org/v10.dtd:orientation "portrait") - (http://www.gnumeric.org/v10.dtd:Header - (@ (Right "") (Middle "&[TAB]") (Left ""))) - (http://www.gnumeric.org/v10.dtd:Footer - (@ (Right "") (Middle "Page &[PAGE]") (Left ""))) - (http://www.gnumeric.org/v10.dtd:paper "na_letter")) - (http://www.gnumeric.org/v10.dtd:Styles - (http://www.gnumeric.org/v10.dtd:StyleRegion - (@ (startRow "0") (startCol "0") (endRow "65535") (endCol "255")) - (http://www.gnumeric.org/v10.dtd:Style - (@ (WrapText "0") - (VAlign "2") - (ShrinkToFit "0") - (Shade "0") - (Rotation "0") - (PatternColor "0:0:0") - (Locked "1") - (Indent "0") - (Hidden "0") - (HAlign "1") - (Format "General") - (Fore "0:0:0") - (Back "FFFF:FFFF:FFFF")) - (http://www.gnumeric.org/v10.dtd:Font - (@ (Unit "10") - (Underline "0") - (StrikeThrough "0") - (Script "0") - (Italic "0") - (Bold "0")) - "Sans") - (http://www.gnumeric.org/v10.dtd:StyleBorder - (http://www.gnumeric.org/v10.dtd:Top (@ (Style "0"))) - (http://www.gnumeric.org/v10.dtd:Bottom (@ (Style "0"))) - (http://www.gnumeric.org/v10.dtd:Left (@ (Style "0"))) - (http://www.gnumeric.org/v10.dtd:Right (@ (Style "0"))) - (http://www.gnumeric.org/v10.dtd:Diagonal (@ (Style "0"))) - (http://www.gnumeric.org/v10.dtd:Rev-Diagonal (@ (Style "0"))))))) - (http://www.gnumeric.org/v10.dtd:Cols - (@ (DefaultSizePts "48")) - (http://www.gnumeric.org/v10.dtd:ColInfo - (@ (Unit "48") (No "0") (MarginB "2") (MarginA "2") (Count "4")))) - (http://www.gnumeric.org/v10.dtd:Rows - (@ (DefaultSizePts "12.75")) - (http://www.gnumeric.org/v10.dtd:RowInfo - (@ (Unit "13.5") (No "0") (MarginB "0") (MarginA "0") (Count "4"))) - (http://www.gnumeric.org/v10.dtd:RowInfo - (@ (Unit "12.75") (No "4") (MarginB "0") (MarginA "0")))) - (http://www.gnumeric.org/v10.dtd:Selections - (@ (CursorRow "3") (CursorCol "2")) - (http://www.gnumeric.org/v10.dtd:Selection - (@ (startRow "3") (startCol "2") (endRow "3") (endCol "2")))) - (http://www.gnumeric.org/v10.dtd:SheetLayout (@ (TopLeft "A1"))) - (http://www.gnumeric.org/v10.dtd:Solver - (@ (ShowIter "0") - (SensitivityR "0") - (ProgramR "0") - (ProblemType "0") - (PerformR "0") - (NonNeg "1") - (MaxTime "60") - (MaxIter "1000") - (LimitsR "0") - (Discr "0") - (AutoScale "0") - (AnswerR "0")))) DELETED txtdb/nada3/sxml/RunsToLock.sxml Index: txtdb/nada3/sxml/RunsToLock.sxml ================================================================== --- txtdb/nada3/sxml/RunsToLock.sxml +++ /dev/null @@ -1,92 +0,0 @@ -(http://www.gnumeric.org/v10.dtd:Sheet - (@ (Visibility "GNM_SHEET_VISIBILITY_VISIBLE") - (OutlineSymbolsRight "1") - (OutlineSymbolsBelow "1") - (HideZero "0") - (HideRowHeader "0") - (HideGrid "0") - (HideColHeader "0") - (DisplayOutlines "1") - (DisplayFormulas "0")) - (http://www.gnumeric.org/v10.dtd:MaxCol "1") - (http://www.gnumeric.org/v10.dtd:MaxRow "1") - (http://www.gnumeric.org/v10.dtd:Zoom "1") - (http://www.gnumeric.org/v10.dtd:PrintInformation - (http://www.gnumeric.org/v10.dtd:Margins - (http://www.gnumeric.org/v10.dtd:top (@ (PrefUnit "cm") (Points "120"))) - (http://www.gnumeric.org/v10.dtd:bottom - (@ (PrefUnit "cm") (Points "120")))) - (http://www.gnumeric.org/v10.dtd:Scale - (@ (type "percentage") (percentage "100"))) - (http://www.gnumeric.org/v10.dtd:vcenter (@ (value "0"))) - (http://www.gnumeric.org/v10.dtd:hcenter (@ (value "0"))) - (http://www.gnumeric.org/v10.dtd:grid (@ (value "0"))) - (http://www.gnumeric.org/v10.dtd:even_if_only_styles (@ (value "0"))) - (http://www.gnumeric.org/v10.dtd:monochrome (@ (value "0"))) - (http://www.gnumeric.org/v10.dtd:draft (@ (value "0"))) - (http://www.gnumeric.org/v10.dtd:titles (@ (value "0"))) - (http://www.gnumeric.org/v10.dtd:order "d_then_r") - (http://www.gnumeric.org/v10.dtd:orientation "portrait") - (http://www.gnumeric.org/v10.dtd:Header - (@ (Right "") (Middle "&[TAB]") (Left ""))) - (http://www.gnumeric.org/v10.dtd:Footer - (@ (Right "") (Middle "Page &[PAGE]") (Left "")))) - (http://www.gnumeric.org/v10.dtd:Styles - (http://www.gnumeric.org/v10.dtd:StyleRegion - (@ (startRow "0") (startCol "0") (endRow "65535") (endCol "255")) - (http://www.gnumeric.org/v10.dtd:Style - (@ (WrapText "0") - (VAlign "2") - (ShrinkToFit "0") - (Shade "0") - (Rotation "0") - (PatternColor "0:0:0") - (Locked "1") - (Indent "0") - (Hidden "0") - (HAlign "1") - (Format "General") - (Fore "0:0:0") - (Back "FFFF:FFFF:FFFF")) - (http://www.gnumeric.org/v10.dtd:Font - (@ (Unit "10") - (Underline "0") - (StrikeThrough "0") - (Script "0") - (Italic "0") - (Bold "0")) - "Sans") - (http://www.gnumeric.org/v10.dtd:StyleBorder - (http://www.gnumeric.org/v10.dtd:Top (@ (Style "0"))) - (http://www.gnumeric.org/v10.dtd:Bottom (@ (Style "0"))) - (http://www.gnumeric.org/v10.dtd:Left (@ (Style "0"))) - (http://www.gnumeric.org/v10.dtd:Right (@ (Style "0"))) - (http://www.gnumeric.org/v10.dtd:Diagonal (@ (Style "0"))) - (http://www.gnumeric.org/v10.dtd:Rev-Diagonal (@ (Style "0"))))))) - (http://www.gnumeric.org/v10.dtd:Cols - (@ (DefaultSizePts "48")) - (http://www.gnumeric.org/v10.dtd:ColInfo - (@ (Unit "48") (No "0") (MarginB "2") (MarginA "2") (Count "2")))) - (http://www.gnumeric.org/v10.dtd:Rows - (@ (DefaultSizePts "12.75")) - (http://www.gnumeric.org/v10.dtd:RowInfo - (@ (Unit "12.75") (No "0") (MarginB "0") (MarginA "0") (Count "2")))) - (http://www.gnumeric.org/v10.dtd:Selections - (@ (CursorRow "0") (CursorCol "0")) - (http://www.gnumeric.org/v10.dtd:Selection - (@ (startRow "0") (startCol "0") (endRow "0") (endCol "0")))) - (http://www.gnumeric.org/v10.dtd:SheetLayout (@ (TopLeft "A1"))) - (http://www.gnumeric.org/v10.dtd:Solver - (@ (ShowIter "0") - (SensitivityR "0") - (ProgramR "0") - (ProblemType "1") - (PerformR "0") - (NonNeg "1") - (MaxTime "0") - (MaxIter "0") - (LimitsR "0") - (Inputs "") - (Discr "0") - (AutoScale "0") - (AnswerR "0")))) DELETED txtdb/nada3/sxml/Second-sheet.sxml Index: txtdb/nada3/sxml/Second-sheet.sxml ================================================================== --- txtdb/nada3/sxml/Second-sheet.sxml +++ /dev/null @@ -1,428 +0,0 @@ -(http://www.gnumeric.org/v10.dtd:Sheet - (@ (Visibility "GNM_SHEET_VISIBILITY_VISIBLE") - (OutlineSymbolsRight "1") - (OutlineSymbolsBelow "1") - (HideZero "0") - (HideRowHeader "0") - (HideGrid "0") - (HideColHeader "0") - (DisplayOutlines "1") - (DisplayFormulas "0")) - (http://www.gnumeric.org/v10.dtd:MaxCol "3") - (http://www.gnumeric.org/v10.dtd:MaxRow "21") - (http://www.gnumeric.org/v10.dtd:Zoom "1") - (http://www.gnumeric.org/v10.dtd:Names - (http://www.gnumeric.org/v10.dtd:Name - (http://www.gnumeric.org/v10.dtd:name "Sheet_Title") - (http://www.gnumeric.org/v10.dtd:value "\"Second-sheet\"") - (http://www.gnumeric.org/v10.dtd:position "A1")) - (http://www.gnumeric.org/v10.dtd:Name - (http://www.gnumeric.org/v10.dtd:name "Print_Area") - (http://www.gnumeric.org/v10.dtd:value "#REF!") - (http://www.gnumeric.org/v10.dtd:position "A1"))) - (http://www.gnumeric.org/v10.dtd:PrintInformation - (http://www.gnumeric.org/v10.dtd:Margins - (http://www.gnumeric.org/v10.dtd:top - (@ (PrefUnit "mm") (Points "93.26"))) - (http://www.gnumeric.org/v10.dtd:bottom - (@ (PrefUnit "mm") (Points "93.26"))) - (http://www.gnumeric.org/v10.dtd:left (@ (PrefUnit "Pt") (Points "72"))) - (http://www.gnumeric.org/v10.dtd:right (@ (PrefUnit "Pt") (Points "72"))) - (http://www.gnumeric.org/v10.dtd:header - (@ (PrefUnit "Pt") (Points "72"))) - (http://www.gnumeric.org/v10.dtd:footer - (@ (PrefUnit "Pt") (Points "72")))) - (http://www.gnumeric.org/v10.dtd:Scale - (@ (type "percentage") (percentage "100"))) - (http://www.gnumeric.org/v10.dtd:vcenter (@ (value "0"))) - (http://www.gnumeric.org/v10.dtd:hcenter (@ (value "0"))) - (http://www.gnumeric.org/v10.dtd:grid (@ (value "0"))) - (http://www.gnumeric.org/v10.dtd:even_if_only_styles (@ (value "0"))) - (http://www.gnumeric.org/v10.dtd:monochrome (@ (value "0"))) - (http://www.gnumeric.org/v10.dtd:draft (@ (value "0"))) - (http://www.gnumeric.org/v10.dtd:titles (@ (value "0"))) - (http://www.gnumeric.org/v10.dtd:order "d_then_r") - (http://www.gnumeric.org/v10.dtd:orientation "portrait") - (http://www.gnumeric.org/v10.dtd:Header - (@ (Right "") (Middle "&[tab]") (Left ""))) - (http://www.gnumeric.org/v10.dtd:Footer - (@ (Right "") (Middle "&[page]") (Left ""))) - (http://www.gnumeric.org/v10.dtd:paper "na_letter")) - (http://www.gnumeric.org/v10.dtd:Styles - (http://www.gnumeric.org/v10.dtd:StyleRegion - (@ (startRow "4096") (startCol "0") (endRow "65535") (endCol "63")) - (http://www.gnumeric.org/v10.dtd:Style - (@ (WrapText "0") - (VAlign "2") - (ShrinkToFit "0") - (Shade "0") - (Rotation "0") - (PatternColor "0:0:0") - (Locked "1") - (Indent "0") - (Hidden "0") - (HAlign "1") - (Format "General") - (Fore "0:0:0") - (Back "FFFF:FFFF:FFFF")) - (http://www.gnumeric.org/v10.dtd:Font - (@ (Unit "10") - (Underline "0") - (StrikeThrough "0") - (Script "0") - (Italic "0") - (Bold "0")) - "Sans") - (http://www.gnumeric.org/v10.dtd:StyleBorder - (http://www.gnumeric.org/v10.dtd:Top (@ (Style "0"))) - (http://www.gnumeric.org/v10.dtd:Bottom (@ (Style "0"))) - (http://www.gnumeric.org/v10.dtd:Left (@ (Style "0"))) - (http://www.gnumeric.org/v10.dtd:Right (@ (Style "0"))) - (http://www.gnumeric.org/v10.dtd:Diagonal (@ (Style "0"))) - (http://www.gnumeric.org/v10.dtd:Rev-Diagonal (@ (Style "0")))))) - (http://www.gnumeric.org/v10.dtd:StyleRegion - (@ (startRow "0") (startCol "4") (endRow "255") (endCol "15")) - (http://www.gnumeric.org/v10.dtd:Style - (@ (WrapText "0") - (VAlign "2") - (ShrinkToFit "0") - (Shade "0") - (Rotation "0") - (PatternColor "0:0:0") - (Locked "1") - (Indent "0") - (Hidden "0") - (HAlign "1") - (Format "General") - (Fore "0:0:0") - (Back "FFFF:FFFF:FFFF")) - (http://www.gnumeric.org/v10.dtd:Font - (@ (Unit "10") - (Underline "0") - (StrikeThrough "0") - (Script "0") - (Italic "0") - (Bold "0")) - "Sans") - (http://www.gnumeric.org/v10.dtd:StyleBorder - (http://www.gnumeric.org/v10.dtd:Top (@ (Style "0"))) - (http://www.gnumeric.org/v10.dtd:Bottom (@ (Style "0"))) - (http://www.gnumeric.org/v10.dtd:Left (@ (Style "0"))) - (http://www.gnumeric.org/v10.dtd:Right (@ (Style "0"))) - (http://www.gnumeric.org/v10.dtd:Diagonal (@ (Style "0"))) - (http://www.gnumeric.org/v10.dtd:Rev-Diagonal (@ (Style "0")))))) - (http://www.gnumeric.org/v10.dtd:StyleRegion - (@ (startRow "32") (startCol "0") (endRow "255") (endCol "3")) - (http://www.gnumeric.org/v10.dtd:Style - (@ (WrapText "0") - (VAlign "2") - (ShrinkToFit "0") - (Shade "0") - (Rotation "0") - (PatternColor "0:0:0") - (Locked "1") - (Indent "0") - (Hidden "0") - (HAlign "1") - (Format "General") - (Fore "0:0:0") - (Back "FFFF:FFFF:FFFF")) - (http://www.gnumeric.org/v10.dtd:Font - (@ (Unit "10") - (Underline "0") - (StrikeThrough "0") - (Script "0") - (Italic "0") - (Bold "0")) - "Sans") - (http://www.gnumeric.org/v10.dtd:StyleBorder - (http://www.gnumeric.org/v10.dtd:Top (@ (Style "0"))) - (http://www.gnumeric.org/v10.dtd:Bottom (@ (Style "0"))) - (http://www.gnumeric.org/v10.dtd:Left (@ (Style "0"))) - (http://www.gnumeric.org/v10.dtd:Right (@ (Style "0"))) - (http://www.gnumeric.org/v10.dtd:Diagonal (@ (Style "0"))) - (http://www.gnumeric.org/v10.dtd:Rev-Diagonal (@ (Style "0")))))) - (http://www.gnumeric.org/v10.dtd:StyleRegion - (@ (startRow "17") (startCol "3") (endRow "31") (endCol "3")) - (http://www.gnumeric.org/v10.dtd:Style - (@ (WrapText "0") - (VAlign "2") - (ShrinkToFit "0") - (Shade "0") - (Rotation "0") - (PatternColor "0:0:0") - (Locked "1") - (Indent "0") - (Hidden "0") - (HAlign "1") - (Format "General") - (Fore "0:0:0") - (Back "FFFF:FFFF:FFFF")) - (http://www.gnumeric.org/v10.dtd:Font - (@ (Unit "10") - (Underline "0") - (StrikeThrough "0") - (Script "0") - (Italic "0") - (Bold "0")) - "Sans") - (http://www.gnumeric.org/v10.dtd:StyleBorder - (http://www.gnumeric.org/v10.dtd:Top (@ (Style "0"))) - (http://www.gnumeric.org/v10.dtd:Bottom (@ (Style "0"))) - (http://www.gnumeric.org/v10.dtd:Left (@ (Style "0"))) - (http://www.gnumeric.org/v10.dtd:Right (@ (Style "0"))) - (http://www.gnumeric.org/v10.dtd:Diagonal (@ (Style "0"))) - (http://www.gnumeric.org/v10.dtd:Rev-Diagonal (@ (Style "0")))))) - (http://www.gnumeric.org/v10.dtd:StyleRegion - (@ (startRow "0") (startCol "0") (endRow "31") (endCol "2")) - (http://www.gnumeric.org/v10.dtd:Style - (@ (WrapText "0") - (VAlign "2") - (ShrinkToFit "0") - (Shade "0") - (Rotation "0") - (PatternColor "0:0:0") - (Locked "1") - (Indent "0") - (Hidden "0") - (HAlign "1") - (Format "General") - (Fore "0:0:0") - (Back "FFFF:FFFF:FFFF")) - (http://www.gnumeric.org/v10.dtd:Font - (@ (Unit "10") - (Underline "0") - (StrikeThrough "0") - (Script "0") - (Italic "0") - (Bold "0")) - "Sans") - (http://www.gnumeric.org/v10.dtd:StyleBorder - (http://www.gnumeric.org/v10.dtd:Top (@ (Style "0"))) - (http://www.gnumeric.org/v10.dtd:Bottom (@ (Style "0"))) - (http://www.gnumeric.org/v10.dtd:Left (@ (Style "0"))) - (http://www.gnumeric.org/v10.dtd:Right (@ (Style "0"))) - (http://www.gnumeric.org/v10.dtd:Diagonal (@ (Style "0"))) - (http://www.gnumeric.org/v10.dtd:Rev-Diagonal (@ (Style "0")))))) - (http://www.gnumeric.org/v10.dtd:StyleRegion - (@ (startRow "16") (startCol "3") (endRow "16") (endCol "3")) - (http://www.gnumeric.org/v10.dtd:Style - (@ (WrapText "0") - (VAlign "2") - (ShrinkToFit "0") - (Shade "1") - (Rotation "0") - (PatternColor "FFFF:FFFF:0") - (Locked "1") - (Indent "0") - (Hidden "0") - (HAlign "1") - (Format "General") - (Fore "0:0:0") - (Back "FFFF:CCCC:0")) - (http://www.gnumeric.org/v10.dtd:Font - (@ (Unit "10") - (Underline "0") - (StrikeThrough "0") - (Script "0") - (Italic "0") - (Bold "0")) - "Sans") - (http://www.gnumeric.org/v10.dtd:StyleBorder - (http://www.gnumeric.org/v10.dtd:Top (@ (Style "0"))) - (http://www.gnumeric.org/v10.dtd:Bottom (@ (Style "0"))) - (http://www.gnumeric.org/v10.dtd:Left (@ (Style "0"))) - (http://www.gnumeric.org/v10.dtd:Right (@ (Style "0"))) - (http://www.gnumeric.org/v10.dtd:Diagonal (@ (Style "0"))) - (http://www.gnumeric.org/v10.dtd:Rev-Diagonal (@ (Style "0")))))) - (http://www.gnumeric.org/v10.dtd:StyleRegion - (@ (startRow "0") (startCol "16") (endRow "4095") (endCol "63")) - (http://www.gnumeric.org/v10.dtd:Style - (@ (WrapText "0") - (VAlign "2") - (ShrinkToFit "0") - (Shade "0") - (Rotation "0") - (PatternColor "0:0:0") - (Locked "1") - (Indent "0") - (Hidden "0") - (HAlign "1") - (Format "General") - (Fore "0:0:0") - (Back "FFFF:FFFF:FFFF")) - (http://www.gnumeric.org/v10.dtd:Font - (@ (Unit "10") - (Underline "0") - (StrikeThrough "0") - (Script "0") - (Italic "0") - (Bold "0")) - "Sans") - (http://www.gnumeric.org/v10.dtd:StyleBorder - (http://www.gnumeric.org/v10.dtd:Top (@ (Style "0"))) - (http://www.gnumeric.org/v10.dtd:Bottom (@ (Style "0"))) - (http://www.gnumeric.org/v10.dtd:Left (@ (Style "0"))) - (http://www.gnumeric.org/v10.dtd:Right (@ (Style "0"))) - (http://www.gnumeric.org/v10.dtd:Diagonal (@ (Style "0"))) - (http://www.gnumeric.org/v10.dtd:Rev-Diagonal (@ (Style "0")))))) - (http://www.gnumeric.org/v10.dtd:StyleRegion - (@ (startRow "0") (startCol "64") (endRow "65535") (endCol "255")) - (http://www.gnumeric.org/v10.dtd:Style - (@ (WrapText "0") - (VAlign "2") - (ShrinkToFit "0") - (Shade "0") - (Rotation "0") - (PatternColor "0:0:0") - (Locked "1") - (Indent "0") - (Hidden "0") - (HAlign "1") - (Format "General") - (Fore "0:0:0") - (Back "FFFF:FFFF:FFFF")) - (http://www.gnumeric.org/v10.dtd:Font - (@ (Unit "10") - (Underline "0") - (StrikeThrough "0") - (Script "0") - (Italic "0") - (Bold "0")) - "Sans") - (http://www.gnumeric.org/v10.dtd:StyleBorder - (http://www.gnumeric.org/v10.dtd:Top (@ (Style "0"))) - (http://www.gnumeric.org/v10.dtd:Bottom (@ (Style "0"))) - (http://www.gnumeric.org/v10.dtd:Left (@ (Style "0"))) - (http://www.gnumeric.org/v10.dtd:Right (@ (Style "0"))) - (http://www.gnumeric.org/v10.dtd:Diagonal (@ (Style "0"))) - (http://www.gnumeric.org/v10.dtd:Rev-Diagonal (@ (Style "0")))))) - (http://www.gnumeric.org/v10.dtd:StyleRegion - (@ (startRow "1") (startCol "3") (endRow "15") (endCol "3")) - (http://www.gnumeric.org/v10.dtd:Style - (@ (WrapText "0") - (VAlign "2") - (ShrinkToFit "0") - (Shade "0") - (Rotation "0") - (PatternColor "0:0:0") - (Locked "1") - (Indent "0") - (Hidden "0") - (HAlign "1") - (Format "General") - (Fore "0:0:0") - (Back "FFFF:FFFF:FFFF")) - (http://www.gnumeric.org/v10.dtd:Font - (@ (Unit "10") - (Underline "0") - (StrikeThrough "0") - (Script "0") - (Italic "0") - (Bold "0")) - "Sans") - (http://www.gnumeric.org/v10.dtd:StyleBorder - (http://www.gnumeric.org/v10.dtd:Top (@ (Style "0"))) - (http://www.gnumeric.org/v10.dtd:Bottom (@ (Style "0"))) - (http://www.gnumeric.org/v10.dtd:Left (@ (Style "0"))) - (http://www.gnumeric.org/v10.dtd:Right (@ (Style "0"))) - (http://www.gnumeric.org/v10.dtd:Diagonal (@ (Style "0"))) - (http://www.gnumeric.org/v10.dtd:Rev-Diagonal (@ (Style "0")))))) - (http://www.gnumeric.org/v10.dtd:StyleRegion - (@ (startRow "0") (startCol "3") (endRow "0") (endCol "3")) - (http://www.gnumeric.org/v10.dtd:Style - (@ (WrapText "0") - (VAlign "2") - (ShrinkToFit "0") - (Shade "0") - (Rotation "0") - (PatternColor "0:0:0") - (Locked "1") - (Indent "0") - (Hidden "0") - (HAlign "1") - (Format "General") - (Fore "0:0:0") - (Back "FFFF:FFFF:FFFF")) - (http://www.gnumeric.org/v10.dtd:Font - (@ (Unit "28") - (Underline "0") - (StrikeThrough "0") - (Script "0") - (Italic "0") - (Bold "0")) - "Sans") - (http://www.gnumeric.org/v10.dtd:StyleBorder - (http://www.gnumeric.org/v10.dtd:Top (@ (Style "0"))) - (http://www.gnumeric.org/v10.dtd:Bottom (@ (Style "0"))) - (http://www.gnumeric.org/v10.dtd:Left (@ (Style "0"))) - (http://www.gnumeric.org/v10.dtd:Right (@ (Style "0"))) - (http://www.gnumeric.org/v10.dtd:Diagonal (@ (Style "0"))) - (http://www.gnumeric.org/v10.dtd:Rev-Diagonal (@ (Style "0")))))) - (http://www.gnumeric.org/v10.dtd:StyleRegion - (@ (startRow "256") (startCol "0") (endRow "4095") (endCol "15")) - (http://www.gnumeric.org/v10.dtd:Style - (@ (WrapText "0") - (VAlign "2") - (ShrinkToFit "0") - (Shade "0") - (Rotation "0") - (PatternColor "0:0:0") - (Locked "1") - (Indent "0") - (Hidden "0") - (HAlign "1") - (Format "General") - (Fore "0:0:0") - (Back "FFFF:FFFF:FFFF")) - (http://www.gnumeric.org/v10.dtd:Font - (@ (Unit "10") - (Underline "0") - (StrikeThrough "0") - (Script "0") - (Italic "0") - (Bold "0")) - "Sans") - (http://www.gnumeric.org/v10.dtd:StyleBorder - (http://www.gnumeric.org/v10.dtd:Top (@ (Style "0"))) - (http://www.gnumeric.org/v10.dtd:Bottom (@ (Style "0"))) - (http://www.gnumeric.org/v10.dtd:Left (@ (Style "0"))) - (http://www.gnumeric.org/v10.dtd:Right (@ (Style "0"))) - (http://www.gnumeric.org/v10.dtd:Diagonal (@ (Style "0"))) - (http://www.gnumeric.org/v10.dtd:Rev-Diagonal (@ (Style "0"))))))) - (http://www.gnumeric.org/v10.dtd:Cols - (@ (DefaultSizePts "48")) - (http://www.gnumeric.org/v10.dtd:ColInfo - (@ (Unit "64.01") (No "0") (MarginB "2") (MarginA "2"))) - (http://www.gnumeric.org/v10.dtd:ColInfo - (@ (Unit "48") (No "1") (MarginB "2") (MarginA "2"))) - (http://www.gnumeric.org/v10.dtd:ColInfo - (@ (Unit "99") (No "2") (MarginB "2") (MarginA "2") (HardSize "1"))) - (http://www.gnumeric.org/v10.dtd:ColInfo - (@ (Unit "227.2") (No "3") (MarginB "2") (MarginA "2") (HardSize "1")))) - (http://www.gnumeric.org/v10.dtd:Rows - (@ (DefaultSizePts "12.1")) - (http://www.gnumeric.org/v10.dtd:RowInfo - (@ (Unit "60") (No "0") (MarginB "0") (MarginA "0") (HardSize "1"))) - (http://www.gnumeric.org/v10.dtd:RowInfo - (@ (Unit "13.5") (No "1") (MarginB "0") (MarginA "0") (Count "17"))) - (http://www.gnumeric.org/v10.dtd:RowInfo - (@ (Unit "12.1") (No "18") (MarginB "0") (MarginA "0") (Count "4")))) - (http://www.gnumeric.org/v10.dtd:Selections - (@ (CursorRow "0") (CursorCol "3")) - (http://www.gnumeric.org/v10.dtd:Selection - (@ (startRow "0") (startCol "3") (endRow "0") (endCol "3")))) - (http://www.gnumeric.org/v10.dtd:SheetLayout (@ (TopLeft "A1"))) - (http://www.gnumeric.org/v10.dtd:Solver - (@ (ShowIter "0") - (SensitivityR "0") - (ProgramR "0") - (ProblemType "0") - (PerformR "0") - (NonNeg "1") - (MaxTime "60") - (MaxIter "1000") - (LimitsR "0") - (Discr "0") - (AutoScale "0") - (AnswerR "0")))) DELETED txtdb/nada3/sxml/Sheet3.sxml Index: txtdb/nada3/sxml/Sheet3.sxml ================================================================== --- txtdb/nada3/sxml/Sheet3.sxml +++ /dev/null @@ -1,100 +0,0 @@ -(http://www.gnumeric.org/v10.dtd:Sheet - (@ (Visibility "GNM_SHEET_VISIBILITY_VISIBLE") - (OutlineSymbolsRight "1") - (OutlineSymbolsBelow "1") - (HideZero "0") - (HideRowHeader "0") - (HideGrid "0") - (HideColHeader "0") - (GridColor "0:0:0") - (DisplayOutlines "1") - (DisplayFormulas "0")) - (http://www.gnumeric.org/v10.dtd:MaxCol "0") - (http://www.gnumeric.org/v10.dtd:MaxRow "0") - (http://www.gnumeric.org/v10.dtd:Zoom "1") - (http://www.gnumeric.org/v10.dtd:Names - (http://www.gnumeric.org/v10.dtd:Name - (http://www.gnumeric.org/v10.dtd:name "Print_Area") - (http://www.gnumeric.org/v10.dtd:value "#REF!") - (http://www.gnumeric.org/v10.dtd:position "A1")) - (http://www.gnumeric.org/v10.dtd:Name - (http://www.gnumeric.org/v10.dtd:name "Sheet_Title") - (http://www.gnumeric.org/v10.dtd:value "\"Sheet3\"") - (http://www.gnumeric.org/v10.dtd:position "A1"))) - (http://www.gnumeric.org/v10.dtd:PrintInformation - (http://www.gnumeric.org/v10.dtd:Margins - (http://www.gnumeric.org/v10.dtd:top - (@ (PrefUnit "mm") (Points "93.26"))) - (http://www.gnumeric.org/v10.dtd:bottom - (@ (PrefUnit "mm") (Points "93.26"))) - (http://www.gnumeric.org/v10.dtd:left (@ (PrefUnit "mm") (Points "72"))) - (http://www.gnumeric.org/v10.dtd:right (@ (PrefUnit "mm") (Points "72"))) - (http://www.gnumeric.org/v10.dtd:header - (@ (PrefUnit "mm") (Points "72"))) - (http://www.gnumeric.org/v10.dtd:footer - (@ (PrefUnit "mm") (Points "72")))) - (http://www.gnumeric.org/v10.dtd:Scale - (@ (type "percentage") (percentage "100"))) - (http://www.gnumeric.org/v10.dtd:vcenter (@ (value "0"))) - (http://www.gnumeric.org/v10.dtd:hcenter (@ (value "0"))) - (http://www.gnumeric.org/v10.dtd:grid (@ (value "0"))) - (http://www.gnumeric.org/v10.dtd:even_if_only_styles (@ (value "0"))) - (http://www.gnumeric.org/v10.dtd:monochrome (@ (value "0"))) - (http://www.gnumeric.org/v10.dtd:draft (@ (value "0"))) - (http://www.gnumeric.org/v10.dtd:titles (@ (value "0"))) - (http://www.gnumeric.org/v10.dtd:do_not_print (@ (value "0"))) - (http://www.gnumeric.org/v10.dtd:print_range (@ (value "0"))) - (http://www.gnumeric.org/v10.dtd:order "d_then_r") - (http://www.gnumeric.org/v10.dtd:orientation "portrait") - (http://www.gnumeric.org/v10.dtd:Header - (@ (Right "") (Middle "&[tab]") (Left ""))) - (http://www.gnumeric.org/v10.dtd:Footer - (@ (Right "") (Middle "&[page]") (Left ""))) - (http://www.gnumeric.org/v10.dtd:paper "na_letter") - (http://www.gnumeric.org/v10.dtd:comments "in_place") - (http://www.gnumeric.org/v10.dtd:errors "as_displayed")) - (http://www.gnumeric.org/v10.dtd:Styles - (http://www.gnumeric.org/v10.dtd:StyleRegion - (@ (startRow "0") (startCol "0") (endRow "65535") (endCol "255")) - (http://www.gnumeric.org/v10.dtd:Style - (@ (WrapText "0") - (VAlign "2") - (ShrinkToFit "0") - (Shade "0") - (Rotation "0") - (PatternColor "0:0:0") - (Locked "1") - (Indent "0") - (Hidden "0") - (HAlign "1") - (Format "General") - (Fore "0:0:0") - (Back "FFFF:FFFF:FFFF")) - (http://www.gnumeric.org/v10.dtd:Font - (@ (Unit "10") - (Underline "0") - (StrikeThrough "0") - (Script "0") - (Italic "0") - (Bold "0")) - "Sans")))) - (http://www.gnumeric.org/v10.dtd:Cols - (@ (DefaultSizePts "48")) - (http://www.gnumeric.org/v10.dtd:ColInfo (@ (Unit "64.01") (No "0")))) - (http://www.gnumeric.org/v10.dtd:Rows - (@ (DefaultSizePts "12.1")) - (http://www.gnumeric.org/v10.dtd:RowInfo (@ (Unit "12.82") (No "0")))) - (http://www.gnumeric.org/v10.dtd:Selections - (@ (CursorRow "0") (CursorCol "0")) - (http://www.gnumeric.org/v10.dtd:Selection - (@ (startRow "0") (startCol "0") (endRow "0") (endCol "0")))) - (http://www.gnumeric.org/v10.dtd:SheetLayout (@ (TopLeft "A1"))) - (http://www.gnumeric.org/v10.dtd:Solver - (@ (ProgramR "0") - (ProblemType "0") - (NonNeg "1") - (ModelType "0") - (MaxTime "60") - (MaxIter "1000") - (Discr "0") - (AutoScale "0")))) DELETED txtdb/nada3/sxml/_sheets.sxml Index: txtdb/nada3/sxml/_sheets.sxml ================================================================== --- txtdb/nada3/sxml/_sheets.sxml +++ /dev/null @@ -1,46 +0,0 @@ -((@ (http://www.w3.org/2001/XMLSchema-instance:schemaLocation - "http://www.gnumeric.org/v8.xsd")) - (http://www.gnumeric.org/v10.dtd:Version - (@ (Minor "3") (Major "6") (Full "1.6.3") (Epoch "1"))) - (http://www.gnumeric.org/v10.dtd:Attributes - (http://www.gnumeric.org/v10.dtd:Attribute - (http://www.gnumeric.org/v10.dtd:type "4") - (http://www.gnumeric.org/v10.dtd:name - "WorkbookView::show_horizontal_scrollbar") - (http://www.gnumeric.org/v10.dtd:value "TRUE")) - (http://www.gnumeric.org/v10.dtd:Attribute - (http://www.gnumeric.org/v10.dtd:type "4") - (http://www.gnumeric.org/v10.dtd:name - "WorkbookView::show_vertical_scrollbar") - (http://www.gnumeric.org/v10.dtd:value "TRUE")) - (http://www.gnumeric.org/v10.dtd:Attribute - (http://www.gnumeric.org/v10.dtd:type "4") - (http://www.gnumeric.org/v10.dtd:name "WorkbookView::show_notebook_tabs") - (http://www.gnumeric.org/v10.dtd:value "TRUE")) - (http://www.gnumeric.org/v10.dtd:Attribute - (http://www.gnumeric.org/v10.dtd:type "4") - (http://www.gnumeric.org/v10.dtd:name "WorkbookView::do_auto_completion") - (http://www.gnumeric.org/v10.dtd:value "TRUE")) - (http://www.gnumeric.org/v10.dtd:Attribute - (http://www.gnumeric.org/v10.dtd:type "4") - (http://www.gnumeric.org/v10.dtd:name "WorkbookView::is_protected") - (http://www.gnumeric.org/v10.dtd:value "FALSE"))) - (http://www.gnumeric.org/v10.dtd:Summary - (http://www.gnumeric.org/v10.dtd:Item - (http://www.gnumeric.org/v10.dtd:name "application") - (http://www.gnumeric.org/v10.dtd:val-string "gnumeric")) - (http://www.gnumeric.org/v10.dtd:Item - (http://www.gnumeric.org/v10.dtd:name "author") - (http://www.gnumeric.org/v10.dtd:val-string "matthew.r.welland"))) - (http://www.gnumeric.org/v10.dtd:SheetNameIndex - (http://www.gnumeric.org/v10.dtd:SheetName "First_Sheet") - (http://www.gnumeric.org/v10.dtd:SheetName "Second-sheet") - (http://www.gnumeric.org/v10.dtd:SheetName "RunsToDo") - (http://www.gnumeric.org/v10.dtd:SheetName "RunsToLock")) - (http://www.gnumeric.org/v10.dtd:Geometry (@ (Width "1440") (Height "647"))) - (http://www.gnumeric.org/v10.dtd:UIData (@ (SelectedTab "3"))) - (http://www.gnumeric.org/v10.dtd:Calculation - (@ (MaxIterations "100") - (ManualRecalc "0") - (IterationTolerance "0.001") - (EnableIteration "1")))) DELETED txtdb/nada3/sxml/_workbook.sxml Index: txtdb/nada3/sxml/_workbook.sxml ================================================================== --- txtdb/nada3/sxml/_workbook.sxml +++ /dev/null @@ -1,1 +0,0 @@ -(*TOP* (*PI* xml "version=\"1.0\" encoding=\"UTF-8\"")) DELETED txtdb/testdata.sxml Index: txtdb/testdata.sxml ================================================================== --- txtdb/testdata.sxml +++ /dev/null @@ -1,1273 +0,0 @@ -(*TOP* (*PI* xml "version=\"1.0\" encoding=\"UTF-8\"") - (http://www.gnumeric.org/v10.dtd:Workbook - (@ (http://www.w3.org/2001/XMLSchema-instance:schemaLocation - "http://www.gnumeric.org/v9.xsd")) - (http://www.gnumeric.org/v10.dtd:Version - (@ (Minor "17") (Major "10") (Full "1.10.17") (Epoch "1"))) - (http://www.gnumeric.org/v10.dtd:Attributes - (http://www.gnumeric.org/v10.dtd:Attribute - (http://www.gnumeric.org/v10.dtd:type "4") - (http://www.gnumeric.org/v10.dtd:name - "WorkbookView::show_horizontal_scrollbar") - (http://www.gnumeric.org/v10.dtd:value "TRUE")) - (http://www.gnumeric.org/v10.dtd:Attribute - (http://www.gnumeric.org/v10.dtd:type "4") - (http://www.gnumeric.org/v10.dtd:name - "WorkbookView::show_vertical_scrollbar") - (http://www.gnumeric.org/v10.dtd:value "TRUE")) - (http://www.gnumeric.org/v10.dtd:Attribute - (http://www.gnumeric.org/v10.dtd:type "4") - (http://www.gnumeric.org/v10.dtd:name - "WorkbookView::show_notebook_tabs") - (http://www.gnumeric.org/v10.dtd:value "TRUE")) - (http://www.gnumeric.org/v10.dtd:Attribute - (http://www.gnumeric.org/v10.dtd:type "4") - (http://www.gnumeric.org/v10.dtd:name - "WorkbookView::do_auto_completion") - (http://www.gnumeric.org/v10.dtd:value "TRUE")) - (http://www.gnumeric.org/v10.dtd:Attribute - (http://www.gnumeric.org/v10.dtd:type "4") - (http://www.gnumeric.org/v10.dtd:name - "WorkbookView::is_protected") - (http://www.gnumeric.org/v10.dtd:value "FALSE"))) - (urn:oasis:names:tc:opendocument:xmlns:office:1.0:document-meta - (@ (urn:oasis:names:tc:opendocument:xmlns:office:1.0:version "1.2")) - (urn:oasis:names:tc:opendocument:xmlns:office:1.0:meta - (http://purl.org/dc/elements/1.1/:date "2013-07-14T22:32:27Z") - (urn:oasis:names:tc:opendocument:xmlns:meta:1.0:creation-date - "2013-07-13T04:38:00Z"))) - (http://www.gnumeric.org/v10.dtd:Calculation - (@ (MaxIterations "100") - (ManualRecalc "0") - (IterationTolerance "0.001") - (FloatRadix "2") - (FloatDigits "53") - (EnableIteration "1"))) - (http://www.gnumeric.org/v10.dtd:SheetNameIndex - (http://www.gnumeric.org/v10.dtd:SheetName - (@ (http://www.gnumeric.org/v10.dtd:Rows "65536") - (http://www.gnumeric.org/v10.dtd:Cols "256")) - "First_Sheet") - (http://www.gnumeric.org/v10.dtd:SheetName - (@ (http://www.gnumeric.org/v10.dtd:Rows "65536") - (http://www.gnumeric.org/v10.dtd:Cols "256")) - "Second-sheet") - (http://www.gnumeric.org/v10.dtd:SheetName - (@ (http://www.gnumeric.org/v10.dtd:Rows "65536") - (http://www.gnumeric.org/v10.dtd:Cols "256")) - "Sheet3")) - (http://www.gnumeric.org/v10.dtd:Geometry - (@ (Width "1440") (Height "647"))) - (http://www.gnumeric.org/v10.dtd:Sheets - (http://www.gnumeric.org/v10.dtd:Sheet - (@ (Visibility "GNM_SHEET_VISIBILITY_VISIBLE") - (OutlineSymbolsRight "1") - (OutlineSymbolsBelow "1") - (HideZero "0") - (HideRowHeader "0") - (HideGrid "0") - (HideColHeader "0") - (GridColor "0:0:0") - (DisplayOutlines "1") - (DisplayFormulas "0")) - (http://www.gnumeric.org/v10.dtd:Name "First_Sheet") - (http://www.gnumeric.org/v10.dtd:MaxCol "8") - (http://www.gnumeric.org/v10.dtd:MaxRow "17") - (http://www.gnumeric.org/v10.dtd:Zoom "1") - (http://www.gnumeric.org/v10.dtd:Names - (http://www.gnumeric.org/v10.dtd:Name - (http://www.gnumeric.org/v10.dtd:name "Print_Area") - (http://www.gnumeric.org/v10.dtd:value "#REF!") - (http://www.gnumeric.org/v10.dtd:position "A1")) - (http://www.gnumeric.org/v10.dtd:Name - (http://www.gnumeric.org/v10.dtd:name "Sheet_Title") - (http://www.gnumeric.org/v10.dtd:value "\"First_Sheet\"") - (http://www.gnumeric.org/v10.dtd:position "A1"))) - (http://www.gnumeric.org/v10.dtd:PrintInformation - (http://www.gnumeric.org/v10.dtd:Margins - (http://www.gnumeric.org/v10.dtd:top - (@ (PrefUnit "mm") (Points "93.26"))) - (http://www.gnumeric.org/v10.dtd:bottom - (@ (PrefUnit "mm") (Points "93.26"))) - (http://www.gnumeric.org/v10.dtd:left - (@ (PrefUnit "mm") (Points "72"))) - (http://www.gnumeric.org/v10.dtd:right - (@ (PrefUnit "mm") (Points "72"))) - (http://www.gnumeric.org/v10.dtd:header - (@ (PrefUnit "mm") (Points "72"))) - (http://www.gnumeric.org/v10.dtd:footer - (@ (PrefUnit "mm") (Points "72")))) - (http://www.gnumeric.org/v10.dtd:Scale - (@ (type "percentage") (percentage "100"))) - (http://www.gnumeric.org/v10.dtd:vcenter (@ (value "0"))) - (http://www.gnumeric.org/v10.dtd:hcenter (@ (value "0"))) - (http://www.gnumeric.org/v10.dtd:grid (@ (value "0"))) - (http://www.gnumeric.org/v10.dtd:even_if_only_styles - (@ (value "0"))) - (http://www.gnumeric.org/v10.dtd:monochrome (@ (value "0"))) - (http://www.gnumeric.org/v10.dtd:draft (@ (value "0"))) - (http://www.gnumeric.org/v10.dtd:titles (@ (value "0"))) - (http://www.gnumeric.org/v10.dtd:do_not_print (@ (value "0"))) - (http://www.gnumeric.org/v10.dtd:print_range (@ (value "0"))) - (http://www.gnumeric.org/v10.dtd:order "d_then_r") - (http://www.gnumeric.org/v10.dtd:orientation "portrait") - (http://www.gnumeric.org/v10.dtd:Header - (@ (Right "") (Middle "&[tab]") (Left ""))) - (http://www.gnumeric.org/v10.dtd:Footer - (@ (Right "") (Middle "&[page]") (Left ""))) - (http://www.gnumeric.org/v10.dtd:paper "na_letter") - (http://www.gnumeric.org/v10.dtd:comments "in_place") - (http://www.gnumeric.org/v10.dtd:errors "as_displayed")) - (http://www.gnumeric.org/v10.dtd:Styles - (http://www.gnumeric.org/v10.dtd:StyleRegion - (@ (startRow "0") (startCol "0") (endRow "0") (endCol "1")) - (http://www.gnumeric.org/v10.dtd:Style - (@ (WrapText "0") - (VAlign "2") - (ShrinkToFit "0") - (Shade "0") - (Rotation "0") - (PatternColor "0:0:0") - (Locked "1") - (Indent "0") - (Hidden "0") - (HAlign "1") - (Format "General") - (Fore "0:0:0") - (Back "FFFF:FFFF:FFFF")) - (http://www.gnumeric.org/v10.dtd:Font - (@ (Unit "10") - (Underline "0") - (StrikeThrough "0") - (Script "0") - (Italic "0") - (Bold "0")) - "Sans"))) - (http://www.gnumeric.org/v10.dtd:StyleRegion - (@ (startRow "1") (startCol "0") (endRow "17") (endCol "1")) - (http://www.gnumeric.org/v10.dtd:Style - (@ (WrapText "0") - (VAlign "2") - (ShrinkToFit "0") - (Shade "0") - (Rotation "0") - (PatternColor "0:0:0") - (Locked "1") - (Indent "0") - (Hidden "0") - (HAlign "1") - (Format "hh\":\"mm\":\"ss AM/PM") - (Fore "0:0:0") - (Back "FFFF:FFFF:FFFF")) - (http://www.gnumeric.org/v10.dtd:Font - (@ (Unit "10") - (Underline "0") - (StrikeThrough "0") - (Script "0") - (Italic "0") - (Bold "0")) - "Sans"))) - (http://www.gnumeric.org/v10.dtd:StyleRegion - (@ (startRow "18") (startCol "0") (endRow "31") (endCol "2")) - (http://www.gnumeric.org/v10.dtd:Style - (@ (WrapText "0") - (VAlign "2") - (ShrinkToFit "0") - (Shade "0") - (Rotation "0") - (PatternColor "0:0:0") - (Locked "1") - (Indent "0") - (Hidden "0") - (HAlign "1") - (Format "General") - (Fore "0:0:0") - (Back "FFFF:FFFF:FFFF")) - (http://www.gnumeric.org/v10.dtd:Font - (@ (Unit "10") - (Underline "0") - (StrikeThrough "0") - (Script "0") - (Italic "0") - (Bold "0")) - "Sans"))) - (http://www.gnumeric.org/v10.dtd:StyleRegion - (@ (startRow "32") (startCol "0") (endRow "255") (endCol "7")) - (http://www.gnumeric.org/v10.dtd:Style - (@ (WrapText "0") - (VAlign "2") - (ShrinkToFit "0") - (Shade "0") - (Rotation "0") - (PatternColor "0:0:0") - (Locked "1") - (Indent "0") - (Hidden "0") - (HAlign "1") - (Format "General") - (Fore "0:0:0") - (Back "FFFF:FFFF:FFFF")) - (http://www.gnumeric.org/v10.dtd:Font - (@ (Unit "10") - (Underline "0") - (StrikeThrough "0") - (Script "0") - (Italic "0") - (Bold "0")) - "Sans"))) - (http://www.gnumeric.org/v10.dtd:StyleRegion - (@ (startRow "256") - (startCol "0") - (endRow "65535") - (endCol "63")) - (http://www.gnumeric.org/v10.dtd:Style - (@ (WrapText "0") - (VAlign "2") - (ShrinkToFit "0") - (Shade "0") - (Rotation "0") - (PatternColor "0:0:0") - (Locked "1") - (Indent "0") - (Hidden "0") - (HAlign "1") - (Format "General") - (Fore "0:0:0") - (Back "FFFF:FFFF:FFFF")) - (http://www.gnumeric.org/v10.dtd:Font - (@ (Unit "10") - (Underline "0") - (StrikeThrough "0") - (Script "0") - (Italic "0") - (Bold "0")) - "Sans"))) - (http://www.gnumeric.org/v10.dtd:StyleRegion - (@ (startRow "0") (startCol "2") (endRow "1") (endCol "2")) - (http://www.gnumeric.org/v10.dtd:Style - (@ (WrapText "0") - (VAlign "2") - (ShrinkToFit "0") - (Shade "0") - (Rotation "0") - (PatternColor "0:0:0") - (Locked "1") - (Indent "0") - (Hidden "0") - (HAlign "1") - (Format "General") - (Fore "0:0:0") - (Back "FFFF:FFFF:FFFF")) - (http://www.gnumeric.org/v10.dtd:Font - (@ (Unit "10") - (Underline "0") - (StrikeThrough "0") - (Script "0") - (Italic "0") - (Bold "0")) - "Sans"))) - (http://www.gnumeric.org/v10.dtd:StyleRegion - (@ (startRow "2") (startCol "2") (endRow "17") (endCol "2")) - (http://www.gnumeric.org/v10.dtd:Style - (@ (WrapText "0") - (VAlign "2") - (ShrinkToFit "0") - (Shade "0") - (Rotation "0") - (PatternColor "0:0:0") - (Locked "1") - (Indent "0") - (Hidden "0") - (HAlign "1") - (Format "0") - (Fore "0:0:0") - (Back "FFFF:FFFF:FFFF")) - (http://www.gnumeric.org/v10.dtd:Font - (@ (Unit "10") - (Underline "0") - (StrikeThrough "0") - (Script "0") - (Italic "0") - (Bold "0")) - "Sans"))) - (http://www.gnumeric.org/v10.dtd:StyleRegion - (@ (startRow "0") (startCol "3") (endRow "31") (endCol "7")) - (http://www.gnumeric.org/v10.dtd:Style - (@ (WrapText "0") - (VAlign "2") - (ShrinkToFit "0") - (Shade "0") - (Rotation "0") - (PatternColor "0:0:0") - (Locked "1") - (Indent "0") - (Hidden "0") - (HAlign "1") - (Format "General") - (Fore "0:0:0") - (Back "FFFF:FFFF:FFFF")) - (http://www.gnumeric.org/v10.dtd:Font - (@ (Unit "10") - (Underline "0") - (StrikeThrough "0") - (Script "0") - (Italic "0") - (Bold "0")) - "Sans"))) - (http://www.gnumeric.org/v10.dtd:StyleRegion - (@ (startRow "0") (startCol "8") (endRow "255") (endCol "63")) - (http://www.gnumeric.org/v10.dtd:Style - (@ (WrapText "0") - (VAlign "2") - (ShrinkToFit "0") - (Shade "0") - (Rotation "0") - (PatternColor "0:0:0") - (Locked "1") - (Indent "0") - (Hidden "0") - (HAlign "1") - (Format "General") - (Fore "0:0:0") - (Back "FFFF:FFFF:FFFF")) - (http://www.gnumeric.org/v10.dtd:Font - (@ (Unit "10") - (Underline "0") - (StrikeThrough "0") - (Script "0") - (Italic "0") - (Bold "0")) - "Sans"))) - (http://www.gnumeric.org/v10.dtd:StyleRegion - (@ (startRow "0") - (startCol "64") - (endRow "65535") - (endCol "255")) - (http://www.gnumeric.org/v10.dtd:Style - (@ (WrapText "0") - (VAlign "2") - (ShrinkToFit "0") - (Shade "0") - (Rotation "0") - (PatternColor "0:0:0") - (Locked "1") - (Indent "0") - (Hidden "0") - (HAlign "1") - (Format "General") - (Fore "0:0:0") - (Back "FFFF:FFFF:FFFF")) - (http://www.gnumeric.org/v10.dtd:Font - (@ (Unit "10") - (Underline "0") - (StrikeThrough "0") - (Script "0") - (Italic "0") - (Bold "0")) - "Sans")))) - (http://www.gnumeric.org/v10.dtd:Cols - (@ (DefaultSizePts "48")) - (http://www.gnumeric.org/v10.dtd:ColInfo - (@ (Unit "48") (No "0"))) - (http://www.gnumeric.org/v10.dtd:ColInfo - (@ (Unit "99") (No "1") (HardSize "1"))) - (http://www.gnumeric.org/v10.dtd:ColInfo - (@ (Unit "64.01") (No "2") (Count "7")))) - (http://www.gnumeric.org/v10.dtd:Rows - (@ (DefaultSizePts "12.1")) - (http://www.gnumeric.org/v10.dtd:RowInfo - (@ (Unit "12.64") (No "0"))) - (http://www.gnumeric.org/v10.dtd:RowInfo - (@ (Unit "13.5") (No "1") (Count "17")))) - (http://www.gnumeric.org/v10.dtd:Selections - (@ (CursorRow "29") (CursorCol "1")) - (http://www.gnumeric.org/v10.dtd:Selection - (@ (startRow "29") - (startCol "1") - (endRow "29") - (endCol "1")))) - (http://www.gnumeric.org/v10.dtd:Cells - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "60") (Row "0") (Col "1")) - "Time") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "60") (Row "0") (Col "2")) - "DeltaTime") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "60") (Row "0") (Col "3")) - "Ambient") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "60") (Row "0") (Col "4")) - "Firebox") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "60") (Row "0") (Col "5")) - "2nd row") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "60") (Row "0") (Col "6")) - "3rd row") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "60") (Row "0") (Col "7")) - "4th row") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "60") (Row "0") (Col "8")) - "Exit ") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "60") (Row "1") (Col "0")) - "A") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "40") (Row "1") (Col "1")) - "0.32430555555555557") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "40") (Row "1") (Col "2")) - "0") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "40") (Row "1") (Col "3")) - "35.399999999999999") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "40") (Row "1") (Col "4")) - "34.299999999999997") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "40") (Row "1") (Col "5")) - "34.299999999999997") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "40") (Row "1") (Col "6")) - "34.100000000000001") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "40") (Row "1") (Col "7")) - "34") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "40") (Row "1") (Col "8")) - "34") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "60") (Row "2") (Col "0")) - "B") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "40") (Row "2") (Col "1")) - "0.33124999999999999") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (Row "2") (ExprID "1") (Col "2")) - "=days(B3,$B$2)*24*60") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "40") (Row "2") (Col "3")) - "35.399999999999999") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "40") (Row "2") (Col "4")) - "72") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "40") (Row "2") (Col "5")) - "60") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "40") (Row "2") (Col "6")) - "42") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "40") (Row "2") (Col "7")) - "39") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "40") (Row "2") (Col "8")) - "68") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "60") (Row "3") (Col "0")) - "C") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "40") (Row "3") (Col "1")) - "0.3347222222222222") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (Row "3") (ExprID "1") (Col "2"))) - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "40") (Row "3") (Col "3")) - "35") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "40") (Row "3") (Col "4")) - "100") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "40") (Row "3") (Col "5")) - "90") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "40") (Row "3") (Col "6")) - "57") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "40") (Row "3") (Col "7")) - "46") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "40") (Row "3") (Col "8")) - "68") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "60") (Row "4") (Col "0")) - "D") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "40") (Row "4") (Col "1")) - "0.33680555555555558") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (Row "4") (ExprID "1") (Col "2"))) - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "40") (Row "4") (Col "3")) - "35") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "40") (Row "4") (Col "4")) - "130") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "40") (Row "4") (Col "5")) - "116") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "40") (Row "4") (Col "6")) - "69") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "40") (Row "4") (Col "7")) - "52") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "40") (Row "4") (Col "8")) - "68") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "60") (Row "5") (Col "0")) - "E") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "40") (Row "5") (Col "1")) - "0.33888888888888891") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (Row "5") (ExprID "1") (Col "2"))) - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "40") (Row "5") (Col "3")) - "35") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "40") (Row "5") (Col "4")) - "145") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "40") (Row "5") (Col "5")) - "121") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "40") (Row "5") (Col "6")) - "73") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "40") (Row "5") (Col "7")) - "54") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "40") (Row "5") (Col "8")) - "68") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "60") (Row "6") (Col "0")) - "F") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "40") (Row "6") (Col "1")) - "0.34097222222222223") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (Row "6") (ExprID "1") (Col "2"))) - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "40") (Row "6") (Col "3")) - "35") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "40") (Row "6") (Col "4")) - "150") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "40") (Row "6") (Col "5")) - "125") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "40") (Row "6") (Col "6")) - "78") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "40") (Row "6") (Col "7")) - "56") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "40") (Row "6") (Col "8")) - "68") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "60") (Row "7") (Col "0")) - "G") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "40") (Row "7") (Col "1")) - "0.34305555555555556") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (Row "7") (ExprID "1") (Col "2"))) - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "40") (Row "7") (Col "3")) - "35") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "40") (Row "7") (Col "4")) - "150") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "40") (Row "7") (Col "5")) - "128") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "40") (Row "7") (Col "6")) - "82") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "40") (Row "7") (Col "7")) - "60") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "40") (Row "7") (Col "8")) - "69") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "60") (Row "8") (Col "0")) - "H") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "40") (Row "8") (Col "1")) - "0.34583333333333333") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (Row "8") (ExprID "1") (Col "2"))) - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "40") (Row "8") (Col "3")) - "36") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "40") (Row "8") (Col "4")) - "158") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "40") (Row "8") (Col "5")) - "129") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "40") (Row "8") (Col "6")) - "86") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "40") (Row "8") (Col "7")) - "62") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "40") (Row "8") (Col "8")) - "70") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "60") (Row "9") (Col "0")) - "I") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "40") (Row "9") (Col "1")) - "0.34791666666666665") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (Row "9") (ExprID "1") (Col "2"))) - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "40") (Row "9") (Col "3")) - "36") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "40") (Row "9") (Col "4")) - "156") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "40") (Row "9") (Col "5")) - "128") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "40") (Row "9") (Col "6")) - "87") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "40") (Row "9") (Col "7")) - "65") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "40") (Row "9") (Col "8")) - "72") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "60") (Row "10") (Col "0")) - "J") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "40") (Row "10") (Col "1")) - "0.35138888888888886") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (Row "10") (ExprID "1") (Col "2"))) - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "40") (Row "10") (Col "3")) - "37") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "40") (Row "10") (Col "4")) - "152") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "40") (Row "10") (Col "5")) - "126") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "40") (Row "10") (Col "6")) - "89") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "40") (Row "10") (Col "7")) - "67") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "40") (Row "10") (Col "8")) - "75") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "60") (Row "11") (Col "0")) - "K") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "40") (Row "11") (Col "1")) - "0.36666666666666664") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (Row "11") (ExprID "1") (Col "2"))) - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "40") (Row "11") (Col "3")) - "37") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "40") (Row "11") (Col "4")) - "134") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "40") (Row "11") (Col "5")) - "117") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "40") (Row "11") (Col "6")) - "94") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "40") (Row "11") (Col "7")) - "77") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "40") (Row "11") (Col "8")) - "107") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "60") (Row "12") (Col "0")) - "L") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "40") (Row "12") (Col "1")) - "0.37916666666666665") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (Row "12") (ExprID "1") (Col "2"))) - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "40") (Row "12") (Col "3")) - "38") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "40") (Row "12") (Col "4")) - "117") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "40") (Row "12") (Col "5")) - "108") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "40") (Row "12") (Col "6")) - "96") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "40") (Row "12") (Col "7")) - "82") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "40") (Row "12") (Col "8")) - "106") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "60") (Row "13") (Col "0")) - "M") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "40") (Row "13") (Col "1")) - "0.39583333333333331") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (Row "13") (ExprID "1") (Col "2"))) - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "40") (Row "13") (Col "3")) - "39") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "40") (Row "13") (Col "4")) - "100") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "40") (Row "13") (Col "5")) - "100") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "40") (Row "13") (Col "6")) - "93") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "40") (Row "13") (Col "7")) - "82") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "40") (Row "13") (Col "8")) - "106") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "60") (Row "14") (Col "0")) - "N") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "40") (Row "14") (Col "1")) - "0.42222222222222222") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (Row "14") (ExprID "1") (Col "2"))) - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "40") (Row "14") (Col "3")) - "40") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "40") (Row "14") (Col "4")) - "91") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "40") (Row "14") (Col "5")) - "90") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "40") (Row "14") (Col "6")) - "88") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "40") (Row "14") (Col "7")) - "81") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "40") (Row "14") (Col "8")) - "100") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "60") (Row "15") (Col "0")) - "O") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "40") (Row "15") (Col "1")) - "0.45208333333333334") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (Row "15") (ExprID "1") (Col "2"))) - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "40") (Row "15") (Col "3")) - "41") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "40") (Row "15") (Col "4")) - "79") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "40") (Row "15") (Col "5")) - "78") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "40") (Row "15") (Col "6")) - "77") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "40") (Row "15") (Col "7")) - "72") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "40") (Row "15") (Col "8")) - "79") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "60") (Row "16") (Col "0")) - "P") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "40") (Row "16") (Col "1")) - "0.49166666666666664") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (Row "16") (ExprID "1") (Col "2"))) - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "40") (Row "16") (Col "3")) - "41") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "40") (Row "16") (Col "4")) - "68") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "40") (Row "16") (Col "5")) - "63") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "40") (Row "16") (Col "6")) - "64") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "40") (Row "16") (Col "7")) - "62") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "40") (Row "16") (Col "8")) - "68") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "60") (Row "17") (Col "0")) - "Q") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "40") (Row "17") (Col "1")) - "0.5708333333333333") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (Row "17") (ExprID "1") (Col "2"))) - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "40") (Row "17") (Col "3")) - "41.5") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "40") (Row "17") (Col "4")) - "51") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "40") (Row "17") (Col "5")) - "51") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "40") (Row "17") (Col "6")) - "51") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "40") (Row "17") (Col "7")) - "51") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "40") (Row "17") (Col "8")) - "51")) - (http://www.gnumeric.org/v10.dtd:SheetLayout (@ (TopLeft "A1"))) - (http://www.gnumeric.org/v10.dtd:Solver - (@ (ProgramR "0") - (ProblemType "0") - (NonNeg "1") - (ModelType "0") - (MaxTime "60") - (MaxIter "1000") - (Discr "0") - (AutoScale "0")))) - (http://www.gnumeric.org/v10.dtd:Sheet - (@ (Visibility "GNM_SHEET_VISIBILITY_VISIBLE") - (OutlineSymbolsRight "1") - (OutlineSymbolsBelow "1") - (HideZero "0") - (HideRowHeader "0") - (HideGrid "0") - (HideColHeader "0") - (GridColor "0:0:0") - (DisplayOutlines "1") - (DisplayFormulas "0")) - (http://www.gnumeric.org/v10.dtd:Name "Second-sheet") - (http://www.gnumeric.org/v10.dtd:MaxCol "4") - (http://www.gnumeric.org/v10.dtd:MaxRow "20") - (http://www.gnumeric.org/v10.dtd:Zoom "1") - (http://www.gnumeric.org/v10.dtd:Names - (http://www.gnumeric.org/v10.dtd:Name - (http://www.gnumeric.org/v10.dtd:name "Print_Area") - (http://www.gnumeric.org/v10.dtd:value "#REF!") - (http://www.gnumeric.org/v10.dtd:position "A1")) - (http://www.gnumeric.org/v10.dtd:Name - (http://www.gnumeric.org/v10.dtd:name "Sheet_Title") - (http://www.gnumeric.org/v10.dtd:value "\"Second-sheet\"") - (http://www.gnumeric.org/v10.dtd:position "A1"))) - (http://www.gnumeric.org/v10.dtd:PrintInformation - (http://www.gnumeric.org/v10.dtd:Margins - (http://www.gnumeric.org/v10.dtd:top - (@ (PrefUnit "mm") (Points "93.26"))) - (http://www.gnumeric.org/v10.dtd:bottom - (@ (PrefUnit "mm") (Points "93.26"))) - (http://www.gnumeric.org/v10.dtd:left - (@ (PrefUnit "mm") (Points "72"))) - (http://www.gnumeric.org/v10.dtd:right - (@ (PrefUnit "mm") (Points "72"))) - (http://www.gnumeric.org/v10.dtd:header - (@ (PrefUnit "mm") (Points "72"))) - (http://www.gnumeric.org/v10.dtd:footer - (@ (PrefUnit "mm") (Points "72")))) - (http://www.gnumeric.org/v10.dtd:Scale - (@ (type "percentage") (percentage "100"))) - (http://www.gnumeric.org/v10.dtd:vcenter (@ (value "0"))) - (http://www.gnumeric.org/v10.dtd:hcenter (@ (value "0"))) - (http://www.gnumeric.org/v10.dtd:grid (@ (value "0"))) - (http://www.gnumeric.org/v10.dtd:even_if_only_styles - (@ (value "0"))) - (http://www.gnumeric.org/v10.dtd:monochrome (@ (value "0"))) - (http://www.gnumeric.org/v10.dtd:draft (@ (value "0"))) - (http://www.gnumeric.org/v10.dtd:titles (@ (value "0"))) - (http://www.gnumeric.org/v10.dtd:do_not_print (@ (value "0"))) - (http://www.gnumeric.org/v10.dtd:print_range (@ (value "0"))) - (http://www.gnumeric.org/v10.dtd:order "d_then_r") - (http://www.gnumeric.org/v10.dtd:orientation "portrait") - (http://www.gnumeric.org/v10.dtd:Header - (@ (Right "") (Middle "&[tab]") (Left ""))) - (http://www.gnumeric.org/v10.dtd:Footer - (@ (Right "") (Middle "&[page]") (Left ""))) - (http://www.gnumeric.org/v10.dtd:paper "na_letter") - (http://www.gnumeric.org/v10.dtd:comments "in_place") - (http://www.gnumeric.org/v10.dtd:errors "as_displayed")) - (http://www.gnumeric.org/v10.dtd:Styles - (http://www.gnumeric.org/v10.dtd:StyleRegion - (@ (startRow "0") - (startCol "0") - (endRow "65279") - (endCol "255")) - (http://www.gnumeric.org/v10.dtd:Style - (@ (WrapText "0") - (VAlign "2") - (ShrinkToFit "0") - (Shade "0") - (Rotation "0") - (PatternColor "0:0:0") - (Locked "1") - (Indent "0") - (Hidden "0") - (HAlign "1") - (Format "General") - (Fore "0:0:0") - (Back "FFFF:FFFF:FFFF")) - (http://www.gnumeric.org/v10.dtd:Font - (@ (Unit "10") - (Underline "0") - (StrikeThrough "0") - (Script "0") - (Italic "0") - (Bold "0")) - "Sans"))) - (http://www.gnumeric.org/v10.dtd:StyleRegion - (@ (startRow "65280") - (startCol "0") - (endRow "65534") - (endCol "255")) - (http://www.gnumeric.org/v10.dtd:Style - (@ (WrapText "0") - (VAlign "2") - (ShrinkToFit "0") - (Shade "0") - (Rotation "0") - (PatternColor "0:0:0") - (Locked "1") - (Indent "0") - (Hidden "0") - (HAlign "1") - (Format "General") - (Fore "0:0:0") - (Back "FFFF:FFFF:FFFF")) - (http://www.gnumeric.org/v10.dtd:Font - (@ (Unit "10") - (Underline "0") - (StrikeThrough "0") - (Script "0") - (Italic "0") - (Bold "0")) - "Sans"))) - (http://www.gnumeric.org/v10.dtd:StyleRegion - (@ (startRow "65535") - (startCol "0") - (endRow "65535") - (endCol "255")) - (http://www.gnumeric.org/v10.dtd:Style - (@ (WrapText "0") - (VAlign "2") - (ShrinkToFit "0") - (Shade "0") - (Rotation "0") - (PatternColor "0:0:0") - (Locked "1") - (Indent "0") - (Hidden "0") - (HAlign "1") - (Format "General") - (Fore "0:0:0") - (Back "FFFF:FFFF:FFFF")) - (http://www.gnumeric.org/v10.dtd:Font - (@ (Unit "10") - (Underline "0") - (StrikeThrough "0") - (Script "0") - (Italic "0") - (Bold "0")) - "Sans")))) - (http://www.gnumeric.org/v10.dtd:Cols - (@ (DefaultSizePts "48")) - (http://www.gnumeric.org/v10.dtd:ColInfo - (@ (Unit "64.01") (No "0"))) - (http://www.gnumeric.org/v10.dtd:ColInfo - (@ (Unit "48") (No "1") (Count "4")))) - (http://www.gnumeric.org/v10.dtd:Rows - (@ (DefaultSizePts "12.1")) - (http://www.gnumeric.org/v10.dtd:RowInfo - (@ (Unit "13.5") (No "0") (Count "20")))) - (http://www.gnumeric.org/v10.dtd:Selections - (@ (CursorRow "4") (CursorCol "4")) - (http://www.gnumeric.org/v10.dtd:Selection - (@ (startRow "4") (startCol "4") (endRow "4") (endCol "4")))) - (http://www.gnumeric.org/v10.dtd:Cells - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "60") (Row "0") (Col "1")) - "A1") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "40") (Row "0") (Col "2")) - "2") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "60") (Row "0") (Col "3")) - "A1") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "40") (Row "0") (Col "4")) - "3") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "60") (Row "1") (Col "0")) - "V1") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "60") (Row "1") (Col "1")) - "X") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "60") (Row "2") (Col "0")) - "V2") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "60") (Row "2") (Col "2")) - "X") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "60") (Row "3") (Col "0")) - "V3") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "60") (Row "3") (Col "3")) - "X") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "60") (Row "4") (Col "0")) - "V4") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "60") (Row "4") (Col "4")) - "X") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "60") (Row "5") (Col "0")) - "V5") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "60") (Row "5") (Col "3")) - "Y") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "60") (Row "6") (Col "0")) - "V6") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "60") (Row "6") (Col "2")) - "Y") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "60") (Row "7") (Col "0")) - "V7") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "60") (Row "7") (Col "1")) - "Y") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "60") (Row "8") (Col "0")) - "V8") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "60") (Row "8") (Col "1")) - "Z") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "60") (Row "9") (Col "0")) - "V8") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "60") (Row "9") (Col "2")) - "Z") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "60") (Row "10") (Col "0")) - "V10") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "60") (Row "10") (Col "3")) - "Z") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "60") (Row "11") (Col "4")) - "Z") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "60") (Row "12") (Col "0")) - "V11") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "60") (Row "12") (Col "3")) - "E") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "60") (Row "13") (Col "0")) - "V12") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "60") (Row "13") (Col "2")) - "E") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "60") (Row "14") (Col "0")) - "V13") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "60") (Row "14") (Col "1")) - "E") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "60") (Row "15") (Col "0")) - "V14") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "60") (Row "15") (Col "1")) - "B") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "60") (Row "16") (Col "0")) - "V15") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "60") (Row "16") (Col "2")) - "B") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "60") (Row "17") (Col "0")) - "V16") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "60") (Row "17") (Col "3")) - "B") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "60") (Row "18") (Col "4")) - "B") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "60") (Row "19") (Col "0")) - "V17") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "60") (Row "19") (Col "1")) - "-") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "60") (Row "19") (Col "2")) - "+") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "60") (Row "19") (Col "3")) - "=") - (http://www.gnumeric.org/v10.dtd:Cell - (@ (ValueType "60") (Row "19") (Col "4")) - "~")) - (http://www.gnumeric.org/v10.dtd:SheetLayout (@ (TopLeft "A1"))) - (http://www.gnumeric.org/v10.dtd:Solver - (@ (ProgramR "0") - (ProblemType "0") - (NonNeg "1") - (ModelType "0") - (MaxTime "60") - (MaxIter "1000") - (Discr "0") - (AutoScale "0")))) - (http://www.gnumeric.org/v10.dtd:Sheet - (@ (Visibility "GNM_SHEET_VISIBILITY_VISIBLE") - (OutlineSymbolsRight "1") - (OutlineSymbolsBelow "1") - (HideZero "0") - (HideRowHeader "0") - (HideGrid "0") - (HideColHeader "0") - (GridColor "0:0:0") - (DisplayOutlines "1") - (DisplayFormulas "0")) - (http://www.gnumeric.org/v10.dtd:Name "Sheet3") - (http://www.gnumeric.org/v10.dtd:MaxCol "0") - (http://www.gnumeric.org/v10.dtd:MaxRow "0") - (http://www.gnumeric.org/v10.dtd:Zoom "1") - (http://www.gnumeric.org/v10.dtd:Names - (http://www.gnumeric.org/v10.dtd:Name - (http://www.gnumeric.org/v10.dtd:name "Print_Area") - (http://www.gnumeric.org/v10.dtd:value "#REF!") - (http://www.gnumeric.org/v10.dtd:position "A1")) - (http://www.gnumeric.org/v10.dtd:Name - (http://www.gnumeric.org/v10.dtd:name "Sheet_Title") - (http://www.gnumeric.org/v10.dtd:value "\"Sheet3\"") - (http://www.gnumeric.org/v10.dtd:position "A1"))) - (http://www.gnumeric.org/v10.dtd:PrintInformation - (http://www.gnumeric.org/v10.dtd:Margins - (http://www.gnumeric.org/v10.dtd:top - (@ (PrefUnit "mm") (Points "93.26"))) - (http://www.gnumeric.org/v10.dtd:bottom - (@ (PrefUnit "mm") (Points "93.26"))) - (http://www.gnumeric.org/v10.dtd:left - (@ (PrefUnit "mm") (Points "72"))) - (http://www.gnumeric.org/v10.dtd:right - (@ (PrefUnit "mm") (Points "72"))) - (http://www.gnumeric.org/v10.dtd:header - (@ (PrefUnit "mm") (Points "72"))) - (http://www.gnumeric.org/v10.dtd:footer - (@ (PrefUnit "mm") (Points "72")))) - (http://www.gnumeric.org/v10.dtd:Scale - (@ (type "percentage") (percentage "100"))) - (http://www.gnumeric.org/v10.dtd:vcenter (@ (value "0"))) - (http://www.gnumeric.org/v10.dtd:hcenter (@ (value "0"))) - (http://www.gnumeric.org/v10.dtd:grid (@ (value "0"))) - (http://www.gnumeric.org/v10.dtd:even_if_only_styles - (@ (value "0"))) - (http://www.gnumeric.org/v10.dtd:monochrome (@ (value "0"))) - (http://www.gnumeric.org/v10.dtd:draft (@ (value "0"))) - (http://www.gnumeric.org/v10.dtd:titles (@ (value "0"))) - (http://www.gnumeric.org/v10.dtd:do_not_print (@ (value "0"))) - (http://www.gnumeric.org/v10.dtd:print_range (@ (value "0"))) - (http://www.gnumeric.org/v10.dtd:order "d_then_r") - (http://www.gnumeric.org/v10.dtd:orientation "portrait") - (http://www.gnumeric.org/v10.dtd:Header - (@ (Right "") (Middle "&[tab]") (Left ""))) - (http://www.gnumeric.org/v10.dtd:Footer - (@ (Right "") (Middle "&[page]") (Left ""))) - (http://www.gnumeric.org/v10.dtd:paper "na_letter") - (http://www.gnumeric.org/v10.dtd:comments "in_place") - (http://www.gnumeric.org/v10.dtd:errors "as_displayed")) - (http://www.gnumeric.org/v10.dtd:Styles - (http://www.gnumeric.org/v10.dtd:StyleRegion - (@ (startRow "0") - (startCol "0") - (endRow "65535") - (endCol "255")) - (http://www.gnumeric.org/v10.dtd:Style - (@ (WrapText "0") - (VAlign "2") - (ShrinkToFit "0") - (Shade "0") - (Rotation "0") - (PatternColor "0:0:0") - (Locked "1") - (Indent "0") - (Hidden "0") - (HAlign "1") - (Format "General") - (Fore "0:0:0") - (Back "FFFF:FFFF:FFFF")) - (http://www.gnumeric.org/v10.dtd:Font - (@ (Unit "10") - (Underline "0") - (StrikeThrough "0") - (Script "0") - (Italic "0") - (Bold "0")) - "Sans")))) - (http://www.gnumeric.org/v10.dtd:Cols - (@ (DefaultSizePts "48")) - (http://www.gnumeric.org/v10.dtd:ColInfo - (@ (Unit "64.01") (No "0")))) - (http://www.gnumeric.org/v10.dtd:Rows - (@ (DefaultSizePts "12.1")) - (http://www.gnumeric.org/v10.dtd:RowInfo - (@ (Unit "12.82") (No "0")))) - (http://www.gnumeric.org/v10.dtd:Selections - (@ (CursorRow "0") (CursorCol "0")) - (http://www.gnumeric.org/v10.dtd:Selection - (@ (startRow "0") (startCol "0") (endRow "0") (endCol "0")))) - (http://www.gnumeric.org/v10.dtd:Cells) - (http://www.gnumeric.org/v10.dtd:SheetLayout (@ (TopLeft "A1"))) - (http://www.gnumeric.org/v10.dtd:Solver - (@ (ProgramR "0") - (ProblemType "0") - (NonNeg "1") - (ModelType "0") - (MaxTime "60") - (MaxIter "1000") - (Discr "0") - (AutoScale "0"))))) - (http://www.gnumeric.org/v10.dtd:UIData (@ (SelectedTab "0"))))) ADDED ulex.scm Index: ulex.scm ================================================================== --- /dev/null +++ ulex.scm @@ -0,0 +1,24 @@ +;;====================================================================== +;; Copyright 2019, Matthew Welland. +;; +;; This file is part of Megatest. +;; +;; Megatest is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. +;; +;; Megatest is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with Megatest. If not, see . + +;;====================================================================== + +(declare (unit ulex)) +(declare (uses pkts)) + +(include "ulex/ulex.scm") ADDED ulex/ulex.scm Index: ulex/ulex.scm ================================================================== --- /dev/null +++ ulex/ulex.scm @@ -0,0 +1,2252 @@ +;; ulex: Distributed sqlite3 db +;;; +;; Copyright (C) 2018 Matt Welland +;; Redistribution and use in source and binary forms, with or without +;; modification, is permitted. +;; +;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS +;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE +;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT +;; OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR +;; BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE +;; USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH +;; DAMAGE. + +;;====================================================================== +;; ABOUT: +;; See README in the distribution at https://www.kiatoa.com/fossils/ulex +;; NOTES: +;; Why sql-de-lite and not say, dbi? - performance mostly, then simplicity. +;; +;;====================================================================== + +(use mailbox) + +(module ulex + * + +(import scheme posix chicken data-structures ports extras files mailbox) +(import srfi-18 pkts matchable regex + typed-records srfi-69 srfi-1 + srfi-4 regex-case + (prefix sqlite3 sqlite3:) + foreign + tcp6 + ;; ulex-netutil + hostinfo + ) + +;; make it a global? Well, it is local to area module + +(define *captain-pktspec* + `((captain (host . h) + (port . p) + (pid . i) + (ipaddr . a) + ) + #;(data (hostname . h) ;; sender hostname + (port . p) ;; sender port + (ipaddr . a) ;; sender ip + (hostkey . k) ;; sending host key - store info at server under this key + (servkey . s) ;; server key - this needs to match at server end or reject the msg + (format . f) ;; sb=serialized-base64, t=text, sx=sexpr, j=json + (data . d) ;; base64 encoded slln data + ))) + +;; struct for keeping track of our world + +(defstruct udat + ;; captain info + (captain-address #f) + (captain-host #f) + (captain-port #f) + (captain-pid #f) + (captain-lease 0) ;; time (unix epoc) seconds when the lease is up + (ulex-dir (conc (get-environment-variable "HOME") "/.ulex")) + (cpkts-dir (conc (get-environment-variable "HOME") "/.ulex/pkts")) + (cpkt-spec *captain-pktspec*) + ;; this processes info + (my-cpkt-key #f) ;; put Z card here when I create a pkt for myself as captain + (my-address #f) + (my-hostname #f) + (my-port #f) + (my-pid (current-process-id)) + (my-dbs '()) + ;; server and handler thread + (serv-listener #f) ;; this processes server info + (handler-thread #f) + (mboxes (make-hash-table)) ;; key => mbox + ;; other servers + (peers (make-hash-table)) ;; host-port => peer record + (dbowners (make-hash-table)) ;; dbfile => host-port + (handlers (make-hash-table)) ;; dbfile => proc + ;; (outgoing-conns (make-hash-table)) ;; host:port -> conn + (work-queue (make-queue)) ;; most stuff goes here + ;; (fast-queue (make-queue)) ;; super quick stuff goes here (e.g. ping) + (busy #f) ;; is either of the queues busy, use to switch between queuing tasks or doing immediately + ;; app info + (appname #f) + (dbtypes (make-hash-table)) ;; this should be an alist but hash is easier. dbtype => [ initproc syncproc ] + ;; cookies + (cnum 0) ;; cookie num + ) + +;;====================================================================== +;; NEW APPROACH +;;====================================================================== + +;; start-server-find-port ;; gotta have a server port ready from the very begining + +;; udata - all the connection info, captain, server, ulex db etc. MUST BE PASSED IN +;; dbpath - full path and filename of the db to talk to or a symbol naming the db? +;; callname - the remote call to execute +;; params - parameters to pass to the remote call +;; +(define (remote-call udata dbpath dbtype callname . params) + (start-server-find-port udata) ;; ensure we have a local server + (find-or-setup-captain udata) + ;; look at connect, process-request, send, send-receive + (let-values (((cookie-key host-port)(get-db-owner udata dbpath dbtype))) + (send-receive udata host-port callname cookie-key params))) + +;;====================================================================== +;; KEY FUNCTIONS - THESE ARE TOO BE EXPOSED AND USED +;;====================================================================== + +;; connection setup and management functions + +;; This is the basic setup command. Must always be +;; called before connecting to a db using connect. +;; +;; find or become the captain +;; setup and return a ulex object +;; +(define (find-or-setup-captain udata) + ;; see if we already have a captain and if the lease is ok + (if (and (udat-captain-address udata) + (udat-captain-port udata) + (< (current-seconds) (udat-captain-lease udata))) + udata + (let* ((cpkts (get-all-captain-pkts udata)) ;; read captain pkts + (captn (get-winning-pkt cpkts))) + (if captn + (let* ((port (alist-ref 'port captn)) + (host (alist-ref 'host captn)) + (ipaddr (alist-ref 'ipaddr captn)) + (pid (alist-ref 'pid captn)) + (Z (alist-ref 'Z captn))) + (udat-captain-address-set! udata ipaddr) + (udat-captain-host-set! udata host) + (udat-captain-port-set! udata port) + (udat-captain-pid-set! udata pid) + (udat-captain-lease-set! udata (+ (current-seconds) 10)) + (let-values (((success pingtime)(ping udata (conc ipaddr ":" port)))) + (if success + udata + (begin + (print "Found unreachable captain at " ipaddr ":" port ", removing pkt") + (remove-captain-pkt udata captn) + (find-or-setup-captain udata)))) + (begin + (setup-as-captain udata) ;; this saves the thread to captain-thread and starts the thread + (find-or-setup-captain udata))))))) + +;; connect to a specific dbfile +;; - if already connected - return the dbowner host-port +;; - ask the captain who to talk to for this db +;; - put the entry in the dbowners hash as dbfile => host-port +;; +(define (connect udata dbfname dbtype) + (or (hash-table-ref/default (udat-dbowners udata) dbfname #f) + (let-values (((success dbowner-host-port)(get-db-owner udata dbfname dbtype))) + (if success + (begin + ;; just clobber the record, this is the new data no matter what + (hash-table-set! (udat-dbowners udata) dbfname dbowner-host-port) + dbowner-host-port) + #f)))) + +;; returns: success pingtime +;; +;; NOTE: causes the callee to store the info on this host along with the dbs this host currently owns +;; +(define (ping udata host-port) + (let* ((start (current-milliseconds)) + (cookie (make-cookie udata)) + (dbs (udat-my-dbs udata)) + (msg (string-intersperse dbs " ")) + (res (send udata host-port 'ping cookie msg retval: #t)) + (delta (- (current-milliseconds) start))) + (values (equal? res cookie) delta))) + +;; returns: success pingtime +;; +;; NOTE: causes all references to this worker to be wiped out in the +;; callee (ususally the captain) +;; +(define (goodbye-ping udata host-port) + (let* ((start (current-milliseconds)) + (cookie (make-cookie udata)) + (dbs (udat-my-dbs udata)) + (res (send udata host-port 'goodbye cookie "nomsg" retval: #t)) + (delta (- (current-milliseconds) start))) + (values (equal? res cookie) delta))) + +(define (goodbye-captain udata) + (let* ((host-port (udat-captain-host-port udata))) + (if host-port + (goodbye-ping udata host-port) + (values #f -1)))) + +(define (get-db-owner udata dbname dbtype) + (let* ((host-port (udat-captain-host-port udata))) + (if host-port + (let* ((cookie (make-cookie udata)) + (msg #f) ;; (conc dbname " " dbtype)) + (params `(,dbname ,dbtype)) + (res (send udata host-port 'db-owner cookie msg + params: params retval: #t))) + (match (string-split res) + ((retcookie owner-host-port) + (values (equal? retcookie cookie) owner-host-port)))) + (values #f -1)))) + +;; called in ulex-handler to dispatch work, called on the workers side +;; calls (proc params data) +;; returns result with cookie +;; +;; pdat is the info of the caller, used to send the result data +;; prockey is key into udat-handlers hash dereferencing a proc +;; procparam is a first param handed to proc - often to do further derefrencing +;; NOTE: params is intended to be a list of strings, encoding on data +;; is up to the user but data must be a single line +;; +(define (process-request udata pdat dbname cookie prockey procparam data) + (let* ((dbrec (ulex-open-db udata dbname)) ;; this will be a dbconn record, looks for in udata first + (proc (hash-table-ref udata prockey))) + (let* ((result (proc dbrec procparam data))) + result))) + +;; remote-request - send to remote to process in process-request +;; uconn comes from a call to connect and can be used instead of calling connect again +;; uconn is the host-port to call +;; we send dbname to the worker so they know which file to open +;; data must be a string with no newlines, it will be handed to the proc +;; at the remote site unchanged. It is up to the user to encode/decode it's contents +;; +;; rtype: immediate, read-only, normal, low-priority +;; +(define (remote-request udata uconn rtype dbname prockey procparam data) + (let* ((cookie (make-cookie udata))) + (send-receive udata uconn rtype cookie data `(,prockey procparam)))) + +(define (ulex-open-db udata dbname) + #f) + + +;;====================================================================== +;; Ulex db +;; +;; - track who is captain, lease expire time +;; - track who owns what db, lease +;; +;;====================================================================== + +;; +;; +(define (ulex-dbfname) + (let ((dbdir (conc (get-environment-variable "HOME") "/.ulex"))) + (if (not (file-exists? dbdir)) + (create-directory dbdir #t)) + (conc dbdir "/network.db"))) + +;; always goes in ~/.ulex/network.db +;; role is captain, adjutant, node +;; +(define (ulexdb-setup) + (let* ((dbfname (ulex-dbfname)) + (have-db (file-exists? dbfname)) + (db (sqlite3:open-database dbfname))) + (sqlite3:set-busy-handler! db (sqlite3:make-busy-timeout 136000)) + (sqlite3:execute db "PRAGMA synchronous = 0;") + (if (not have-db) + (sqlite3:with-transaction + db + (lambda () + (for-each + (lambda (stmt) + (if stmt (sqlite3:execute db stmt))) + `("CREATE TABLE IF NOT EXISTS nodes + (id INTEGER PRIMARY KEY, + role TEXT NOT NULL, + host TEXT NOT NULL, + port TEXT NOT NULL, + ipadr TEXT NOT NULL, + pid INTEGER NOT NULL, + zcard TEXT NOT NULL, + regtime INTEGER DEFAULT (strftime('%s','now')), + lease_thru INTEGER DEFAULT (strftime('%s','now')), + last_update INTEGER DEFAULT (strftime('%s','now')));" + "CREATE TRIGGER IF NOT EXISTS update_nodes_trigger AFTER UPDATE ON nodes + FOR EACH ROW + BEGIN + UPDATE nodes SET last_update=(strftime('%s','now')) + WHERE id=old.id; + END;" + "CREATE TABLE IF NOT EXISTS dbs + (id INTEGER PRIMARY KEY, + dbname TEXT NOT NULL, + dbfile TEXT NOT NULL, + dbtype TEXT NOT NULL, + host_port TEXT NOT NULL, + regtime INTEGER DEFAULT (strftime('%s','now')), + lease_thru INTEGER DEFAULT (strftime('%s','now')), + last_update INTEGER DEFAULT (strftime('%s','now')));" + "CREATE TRIGGER IF NOT EXISTS update_dbs_trigger AFTER UPDATE ON dbs + FOR EACH ROW + BEGIN + UPDATE dbs SET last_update=(strftime('%s','now')) + WHERE id=old.id; + END;"))))) + db)) + +(define (get-host-port-lease db dbfname) + (sqlite3:fold-row + (lambda (rem host-port lease-thru) + (list host-port lease-thru)) + #f db "SELECT host_port,lease_thru FROM dbs WHERE dbfile = ?" dbfname)) + +(define (register-captain db host ipadr port pid zcard #!key (lease 20)) + (let* ((dbfname (ulex-dbfname)) + (host-port (conc host ":" port))) + (sqlite3:with-transaction + db + (lambda () + (match (get-host-port-lease db dbfname) + ((host-port lease-thru) + (if (> (current-seconds) lease-thru) + (begin + (sqlite3:execute db "UPDATE dbs SET host_port=?,lease_thru=? WHERE dbname=?" + (conc host ":" port) + (+ (current-seconds) lease) + dbfname) + #t) + #f)) + (#f (sqlite3:execute db "INSERT INTO dbs (dbname,dbfile,dbtype,host_port,lease_thru) VALUES (?,?,?,?,?)" + "captain" dbfname "captain" host-port (+ (current-seconds) lease))) + (else (print "ERROR: Unrecognised result from fold-row") + (exit 1))))))) + +;;====================================================================== +;; network utilities +;;====================================================================== + +(define (rate-ip ipaddr) + (regex-case ipaddr + ( "^127\\..*" _ 0 ) + ( "^(10\\.0|192\\.168)\\..*" _ 1 ) + ( else 2 ) )) + +;; Change this to bias for addresses with a reasonable broadcast value? +;; +(define (ip-pref-less? a b) + (> (rate-ip a) (rate-ip b))) + + +(define (get-my-best-address) + (let ((all-my-addresses (get-all-ips)) + ;;(all-my-addresses-old (vector->list (hostinfo-addresses (hostname->hostinfo (get-host-name))))) + ) + (cond + ((null? all-my-addresses) + (get-host-name)) ;; no interfaces? + ((eq? (length all-my-addresses) 1) + (car all-my-addresses)) ;; only one to choose from, just go with it + + (else + (car (sort all-my-addresses ip-pref-less?))) + ;; (else + ;; (ip->string (car (filter (lambda (x) ;; take any but 127. + ;; (not (eq? (u8vector-ref x 0) 127))) + ;; all-my-addresses)))) + + ))) + +(define (get-all-ips-sorted) + (sort (get-all-ips) ip-pref-less?)) + +(define (get-all-ips) + (map ip->string (vector->list + (hostinfo-addresses + (host-information (current-hostname)))))) + +(define (udat-my-host-port udata) + (if (and (udat-my-address udata)(udat-my-port udata)) + (conc (udat-my-address udata) ":" (udat-my-port udata)) + #f)) + +(define (udat-captain-host-port udata) + (if (and (udat-captain-address udata)(udat-captain-port udata)) + (conc (udat-captain-address udata) ":" (udat-captain-port udata)) + #f)) + +(define (udat-get-peer udata host-port) + (hash-table-ref/default (udat-peers udata) host-port #f)) + +;; struct for keeping track of others we are talking to + +(defstruct peer + (addr-port #f) + (hostname #f) + (pid #f) + ;; (inp #f) + ;; (oup #f) + (dbs '()) ;; list of databases this peer is currently handling + ) + +(defstruct work + (peer-dat #f) + (handlerkey #f) + (qrykey #f) + (data #f) + (start (current-milliseconds))) + +#;(defstruct dbowner + (pdat #f) + (last-update (current-seconds))) + +;;====================================================================== +;; Captain functions +;;====================================================================== + +;; NB// This needs to be started in a thread +;; +;; setup to be a captain +;; - local server MUST be started already +;; - create pkt +;; - start server port handler +;; +(define (setup-as-captain udata) + (if (create-captain-pkt udata) + (let* ((my-addr (udat-my-address udata)) + (my-port (udat-my-port udata)) + (th (make-thread (lambda () + (ulex-handler-loop udata)) "Captain handler"))) + (udat-handler-thread-set! udata th) + (udat-captain-address-set! udata my-addr) + (udat-captain-port-set! udata my-port) + (thread-start! th)) + (begin + (print "ERROR: failed to create captain pkt") + #f))) + +;; given a pkts dir read +;; +(define (get-all-captain-pkts udata) + (let* ((pktsdir (let ((d (udat-cpkts-dir udata))) + (if (file-exists? d) + d + (begin + (create-directory d #t) + d)))) + (all-pkt-files (glob (conc pktsdir "/*.pkt"))) + (pkt-spec (udat-cpkt-spec udata))) + (map (lambda (pkt-file) + (read-pkt->alist pkt-file pktspec: pkt-spec)) + all-pkt-files))) + +;; sort by D then Z, return one, choose the oldest then +;; differentiate if needed using the Z key +;;l +(define (get-winning-pkt pkts) + (if (null? pkts) + #f + (car (sort pkts (lambda (a b) + (let ((ad (string->number (alist-ref 'D a))) + (bd (string->number (alist-ref 'D b)))) + (if (eq? a b) + (let ((az (alist-ref 'Z a)) + (bz (alist-ref 'Z b))) + (string>=? az bz)) + (> ad bd)))))))) + +;; put the host, ip, port and pid into a pkt in +;; the captain pkts dir +;; - assumes user has already fired up a server +;; which will be in the udata struct +;; +(define (create-captain-pkt udata) + (if (not (udat-serv-listener udata)) + (begin + (print "ERROR: create-captain-pkt called with out a listener") + #f) + (let* ((pktdat `((port . ,(udat-my-port udata)) + (host . ,(udat-my-hostname udata)) + (ipaddr . ,(udat-my-address udata)) + (pid . ,(udat-my-pid udata)))) + (pktdir (udat-cpkts-dir udata)) + (pktspec (udat-cpkt-spec udata)) + ) + (udat-my-cpkt-key-set! + udata + (write-alist->pkt + pktdir + pktdat + pktspec: pktspec + ptype: 'captain)) + (udat-my-cpkt-key udata)))) + +;; remove pkt associated with captn (the Z key .pkt) +;; +(define (remove-captain-pkt udata captn) + (let ((Z (alist-ref 'Z captn)) + (cpktdir (udat-cpkts-dir udata))) + (delete-file* (conc cpktdir "/" Z ".pkt")))) + +;; call all known peers and tell them to delete their info on the captain +;; thus forcing them to re-read pkts and connect to a new captain +;; call this when the captain needs to exit and if an older captain is +;; detected. Due to delays in sending file meta data in NFS multiple +;; captains can be initiated in a "Storm of Captains", book soon to be +;; on Amazon +;; +(define (drop-captain udata) + (let* ((peers (hash-table-keys (udat-peers udata))) + (cookie (make-cookie udata))) + (for-each + (lambda (host-port) + (send udata host-port 'dropcaptain cookie "nomsg" retval: #t)) + peers))) + +;;====================================================================== +;; server primitives +;;====================================================================== + +(define (make-cookie udata) + (let ((newcnum (+ (udat-cnum udata) 1))) + (udat-cnum-set! udata newcnum) + (conc (udat-my-address udata) ":" + (udat-my-port udata) "-" + (udat-my-pid udata) "-" + newcnum))) + +;; create a tcp listener and return a populated udat struct with +;; my port, address, hostname, pid etc. +;; return #f if fail to find a port to allocate. +;; +;; if udata-in is #f create the record +;; if there is already a serv-listener return the udata +;; +(define (start-server-find-port udata-in #!optional (port 4242)) + (let ((udata (or udata-in (make-udat)))) + (if (udat-serv-listener udata) ;; TODO - add check that the listener is alive and ready? + udata + (handle-exceptions + exn + (if (< port 65535) + (start-server-find-port udata (+ port 1)) + #f) + (connect-server udata port))))) + +(define (connect-server udata port) + ;; (tcp-listener-socket LISTENER)(socket-name so) + ;; sockaddr-address, sockaddr-port, sockaddr->string + (let* ((tlsn (tcp-listen port 1000 #f)) ;; (tcp-listen TCPPORT [BACKLOG [HOST]]) + (addr (get-my-best-address))) ;; (hostinfo-addresses (host-information (current-hostname))) + (udat-my-address-set! udata addr) + (udat-my-port-set! udata port) + (udat-my-hostname-set! udata (get-host-name)) + (udat-serv-listener-set! udata tlsn) + udata)) + +(define (get-peer-dat udata host-port #!optional (hostname #f)(pid #f)) + (let* ((pdat (or (udat-get-peer udata host-port) + (handle-exceptions ;; ERROR - MAKE THIS EXCEPTION HANDLER MORE SPECIFIC + exn + #f + (let ((npdat (make-peer addr-port: host-port))) + (if hostname (peer-hostname-set! npdat hostname)) + (if pid (peer-pid-set! npdat pid)) + npdat))))) + pdat)) + +;; send structured data to recipient +;; +;; NOTE: qrykey is what was called the "cookie" previously +;; +;; retval tells send to expect and wait for return data (one line) and return it or time out +;; this is for ping where we don't want to necessarily have set up our own server yet. +;; +(define (send udata host-port handler qrykey data + #!key (hostname #f)(pid #f)(params '())(retval #f)) + (let* ((my-host-port (udat-my-host-port udata)) + (isme (equal? host-port my-host-port)) ;; am I calling + ;; myself? + (dat (list + handler ;; " " + my-host-port ;; " " + (udat-my-pid udata) ;; " " + qrykey + params ;;(if (null? params) "" (conc " " + ;;(string-intersperse params " "))) + ))) + ;; (print "send isme is " (if isme "true!" "false!") ", + ;; my-host-port: " my-host-port ", host-port: " host-port) + (if isme + (ulex-handler udata dat data) + (handle-exceptions ;; ERROR - MAKE THIS EXCEPTION HANDLER MORE + ;; SPECIFIC + exn + #f + (let-values (((inp oup)(tcp-connect host-port))) + ;; + ;; CONTROL LINE: + ;; handlerkey host:port pid qrykey params ... + ;; + (let ((res + (if (and inp oup) + (let* () + (if my-host-port + (begin + (write dat oup) + (write data oup) ;; send as sexpr + ;; (print "Sent dat: " dat " data: " data) + (if retval + (read inp) + #t)) + (begin + (print "ERROR: send called but no receiver has been setup. Please call setup first!") + #f)) + ;; NOTE: DO NOT BE TEMPTED TO LOOK AT ANY DATA ON INP HERE! + ;; (there is a listener for handling that) + ) + #f))) ;; #f means failed to connect and send + (close-input-port inp) + (close-output-port oup) + res)))))) + +;; send a request to the given host-port and register a mailbox in udata +;; wait for the mailbox data and return it +;; +(define (send-receive udata host-port handler qrykey data #!key (hostname #f)(pid #f)(params '())(timeout 20)) + (let ((mbox (make-mailbox)) + (mbox-time (current-milliseconds)) + (mboxes (udat-mboxes udata))) + (hash-table-set! mboxes qrykey mbox) + (if (send udata host-port handler qrykey data hostname: hostname pid: pid params: params) + (let* ((mbox-timeout-secs timeout) + (mbox-timeout-result 'MBOX_TIMEOUT) + (res (mailbox-receive! mbox mbox-timeout-secs mbox-timeout-result)) + (mbox-receive-time (current-milliseconds))) + (hash-table-delete! mboxes qrykey) + (if (eq? res 'MBOX_TIMEOUT) + #f + res)) + #f))) ;; #f means failed to communicate + +;; +(define (ulex-handler udata controldat data) + (print "controldat: " controldat " data: " data) + (match controldat ;; (string-split controldat) + ((handlerkey host-port pid qrykey params ...) + ;; (print "handlerkey: " handlerkey " host-port: " host-port " pid: " pid " qrykey: " qrykey " params: " params) + (case handlerkey ;; (string->symbol handlerkey) + ((ack)(print "Got ack!")) + ((ping) ;; special case - return result immediately on the same connection + (let* ((proc (hash-table-ref/default (udat-handlers udata) 'ping #f)) + (val (if proc (proc) "gotping")) + (peer (make-peer addr-port: host-port pid: pid)) + (dbshash (udat-dbowners udata))) + (peer-dbs-set! peer params) ;; params for ping is list of dbs owned by pinger + (for-each (lambda (dbfile) + (hash-table-set! dbshash dbfile host-port)) ;; WRONG? + params) ;; register each db in the dbshash + (if (not (hash-table-exists? (udat-peers udata) host-port)) + (hash-table-set! (udat-peers udata) host-port peer)) ;; save the details of this caller in peers + qrykey)) ;; End of ping + ((goodbye) + ;; remove all traces of the caller in db ownership etc. + (let* ((peer (hash-table-ref/default (udat-peers udata) host-port #f)) + (dbs (if peer (peer-dbs peer) '())) + (dbshash (udat-dbowners udata))) + (for-each (lambda (dbfile)(hash-table-delete! dbshash dbfile)) dbs) + (hash-table-delete! (udat-peers udata) host-port) + qrykey)) + ((dropcaptain) + ;; remove all traces of the captain + (udat-captain-address-set! udata #f) + (udat-captain-host-set! udata #f) + (udat-captain-port-set! udata #f) + (udat-captain-pid-set! udata #f) + qrykey) + ((rucaptain) ;; remote is asking if I'm the captain + (if (udat-my-cpkt-key udata) "yes" "no")) + ((db-owner) ;; given a db name who do I send my queries to + ;; look up the file in handlers, if have an entry ping them to be sure + ;; they are still alive and then return that host:port. + ;; if no handler found or if the ping fails pick from peers the oldest that + ;; is managing the fewest dbs + (match params + ((dbfile dbtype) + (let* ((owner-host-port (hash-table-ref/default (udat-dbowners udata) dbfile #f))) + (if owner-host-port + (conc qrykey " " owner-host-port) + (let* ((pdat (or (hash-table-ref/default (udat-peers udata) host-port #f) ;; no owner - caller gets to own it! + (make-peer addr-port: host-port pid: pid dbs: `(,dbfile))))) + (hash-table-set! (udat-peers udata) host-port pdat) + (hash-table-set! (udat-dbowners udata) dbfile host-port) + (conc qrykey " " host-port))))) + (else (conc qrykey " BADDATA")))) + ;; for work items: + ;; handler is one of; immediate, read-only, read-write, high-priority + ((immediate read-only normal low-priority) ;; do this work immediately + ;; host-port (caller), pid (caller), qrykey (cookie), params <= all from first line + ;; data => a single line encoded however you want, or should I build json into it? + (print "handlerkey=" handlerkey) + (let* ((pdat (get-peer-dat udata host-port))) + (match params ;; dbfile prockey procparam + ((dbfile prockey procparam) + (case handlerkey + ((immediate read-only) + (process-request udata pdat dbfile qrykey prockey procparam data)) + ((normal low-priority) ;; split off later and add logic to support low priority + (add-to-work-queue udata pdat dbfile qrykey prockey procparam data)) + (else + #f))) + (else + (print "INFO: params=" params " handlerkey=" handlerkey " controldat=" controldat) + #f)))) + (else + ;; (add-to-work-queue udata (get-peer-dat udata host-port) handlerkey qrykey data) + #f))) + (else + (print "BAD DATA? controldat=" controldat " data=" data) + #f)));; handles the incoming messages and dispatches to queues + +;; +(define (ulex-handler-loop udata) + (let* ((serv-listener (udat-serv-listener udata))) + ;; data comes as two lines + ;; handlerkey resp-addr:resp-port hostname pid qrykey [dbpath/dbfile.db] + ;; data + (let loop ((state 'start)) + (let-values (((inp oup)(tcp-accept serv-listener))) + (let* ((controldat (read inp)) + (data (read inp)) + (resp (ulex-handler udata controldat data))) + (if resp (write resp oup)) + (close-input-port inp) + (close-output-port oup)) + (loop state))))) + +;; add a proc to the handler list, these are done symetrically (i.e. in all instances) +;; so that the proc can be dereferenced remotely +;; +(define (register-handler udata key proc) + (hash-table-set! (udat-handlers udata) key proc)) + + +;;====================================================================== +;; work queues +;;====================================================================== + +(define (add-to-work-queue udata peer-dat handlerkey qrykey data) + (let ((wdat (make-work peer-dat: peer-dat handlerkey: handlerkey qrykey: qrykey data: data))) + (if (udat-busy udata) + (queue-add! (udat-work-queue udata) wdat) + (process-work udata wdat)) ;; passing in wdat tells process-work to first process the passed in wdat + )) + +(define (do-work udata wdat) + #f) + +(define (process-work udata #!optional wdat) + (if wdat (do-work udata wdat)) ;; process wdat + (let ((wqueue (udat-work-queue udata))) + (if (not (queue-empty? wqueue)) + (let loop ((wd (queue-remove! wqueue))) + (do-work udata wd) + (if (not (queue-empty? wqueue)) + (loop (queue-remove! wqueue))))))) + +;;====================================================================== +;; Generic db handling +;; setup a inmem db instance +;; open connection to on-disk db +;; sync on-disk db to inmem +;; get lock in on-disk db for dbowner of this db +;; put sync-proc, init-proc, on-disk handle, inmem handle in dbconn stuct +;; return the stuct +;;====================================================================== + +(defstruct dbconn + (fname #f) + (inmem #f) + (conn #f) + (sync #f) ;; sync proc + (init #f) ;; init proc + (lastsync (current-seconds)) + ) + +(defstruct dbinfo + (initproc #f) + (syncproc #f)) + +;; open inmem and disk database +;; init with initproc +;; return db struct +;; +;; appname; megatest, ulex or something else. +;; +(define (setup-db-connection udata fname-in appname dbtype) + (let* ((is-ulex (eq? appname 'ulex)) + (dbinf (if is-ulex ;; ulex is a built-in special case + (make-dbinfo initproc: ulexdb-init syncproc: ulexdb-sync) + (hash-table-ref/default (udat-dbtypes udata) dbtype #f))) + (initproc (dbinfo-initproc dbinf)) + (syncproc (dbinfo-syncproc dbinf)) + (fname (if is-ulex + (conc (udat-ulex-dir udata) "/ulex.db") + fname-in)) + (inmem-db (open-and-initdb udata #f 'inmem (dbinfo-initproc dbinf))) + (disk-db (open-and-initdb udata fname 'disk (dbinfo-initproc dbinf)))) + (make-dbconn inmem: inmem-db conn: disk-db sync: syncproc init: initproc))) + +;; dest='inmem or 'disk +;; +(define (open-and-initdb udata filename dest init-proc) + (let* ((inmem (eq? dest 'inmem)) + (dbfile (if inmem + ":INMEM:" + filename)) + (dbexists (if inmem #t (file-exists? dbfile))) + (db (sqlite3:open-database dbfile))) + (sqlite3:set-busy-handler! db (sqlite3:make-busy-timeout 136000)) + (if (not dbexists) + (init-proc db)) + db)) + + +;;====================================================================== +;; Previous Ulex db stuff +;;====================================================================== + +(define (ulexdb-init db inmem) + (sqlite3:with-transaction + db + (lambda () + (for-each + (lambda (stmt) + (if stmt (sqlite3:execute db stmt))) + `("CREATE TABLE IF NOT EXISTS processes + (id INTEGER PRIMARY KEY, + host TEXT NOT NULL, + ipadr TEXT NOT NULL, + port INTEGER NOT NULL, + pid INTEGER NOT NULL, + regtime INTEGER DEFAULT (strftime('%s','now')), + last_update INTEGER DEFAULT (strftime('%s','now')));" + (if inmem + "CREATE TRIGGER IF NOT EXISTS update_proces_trigger AFTER UPDATE ON processes + FOR EACH ROW + BEGIN + UPDATE processes SET last_update=(strftime('%s','now')) + WHERE id=old.id; + END;" + #f)))))) + +;; open databases, do initial sync +(define (ulexdb-sync dbconndat udata) + #f) + + +) ;; END OF ULEX + + +;;; ;;====================================================================== +;;; ;; D E B U G H E L P E R S +;;; ;;====================================================================== +;;; +;;; (define (dbg> . args) +;;; (with-output-to-port (current-error-port) +;;; (lambda () +;;; (apply print "dbg> " args)))) +;;; +;;; (define (debug-pp . args) +;;; (if (get-environment-variable "ULEX_DEBUG") +;;; (with-output-to-port (current-error-port) +;;; (lambda () +;;; (apply pp args))))) +;;; +;;; (define *default-debug-port* (current-error-port)) +;;; +;;; (define (sdbg> fn stage-name stage-start stage-end start-time . message) +;;; (if (get-environment-variable "ULEX_DEBUG") +;;; (with-output-to-port *default-debug-port* +;;; (lambda () +;;; (apply print "ulex:" fn " " stage-name " took " (- (if stage-end stage-end (current-milliseconds)) stage-start) " ms. " +;;; (if start-time +;;; (conc "total time " (- (current-milliseconds) start-time) +;;; " ms.") +;;; "") +;;; message +;;; ))))) + +;;====================================================================== +;; M A C R O S +;;====================================================================== +;; iup callbacks are not dumping the stack, this is a work-around +;; + +;; Some of these routines use: +;; +;; http://www.cs.toronto.edu/~gfb/scheme/simple-macros.html +;; +;; Syntax for defining macros in a simple style similar to function definiton, +;; when there is a single pattern for the argument list and there are no keywords. +;; +;; (define-simple-syntax (name arg ...) body ...) +;; +;; +;; (define-syntax define-simple-syntax +;; (syntax-rules () +;; ((_ (name arg ...) body ...) +;; (define-syntax name (syntax-rules () ((name arg ...) (begin body ...))))))) +;; +;; (define-simple-syntax (catch-and-dump proc procname) +;; (handle-exceptions +;; exn +;; (begin +;; (print-call-chain (current-error-port)) +;; (with-output-to-port (current-error-port) +;; (lambda () +;; (print ((condition-property-accessor 'exn 'message) exn)) +;; (print "Callback error in " procname) +;; (print "Full condition info:\n" (condition->list exn))))) +;; (proc))) +;; +;; +;;====================================================================== +;; R E C O R D S +;;====================================================================== + +;;; ;; information about me as a server +;;; ;; +;;; (defstruct area +;;; ;; about this area +;;; (useportlogger #f) +;;; (lowport 32768) +;;; (server-type 'auto) ;; auto=create up to five servers/pkts, main=create pkts, passive=no pkt (unless there are no pkts at all) +;;; (conn #f) +;;; (port #f) +;;; (myaddr (get-my-best-address)) +;;; pktid ;; get pkt from hosts table if needed +;;; pktfile +;;; pktsdir +;;; dbdir +;;; (dbhandles (make-hash-table)) ;; fname => list-of-dbh, NOTE: Should really never need more than one? +;;; (mutex (make-mutex)) +;;; (rtable (make-hash-table)) ;; registration table of available actions +;;; (dbs (make-hash-table)) ;; filename => random number, used for choosing what dbs I serve +;;; ;; about other servers +;;; (hosts (make-hash-table)) ;; key => hostdat +;;; (hoststats (make-hash-table)) ;; key => alist of fname => ( qcount . qtime ) +;;; (reqs (make-hash-table)) ;; uri => queue +;;; ;; work queues +;;; (wqueues (make-hash-table)) ;; fname => qdat +;;; (stats (make-hash-table)) ;; fname => totalqueries +;;; (last-srvup (current-seconds)) ;; last time we updated the known servers +;;; (cookie2mbox (make-hash-table)) ;; map cookie for outstanding request to mailbox of awaiting call +;;; (ready #f) +;;; (health (make-hash-table)) ;; ipaddr:port => num failed pings since last good ping +;;; ) +;;; +;;; ;; host stats +;;; ;; +;;; (defstruct hostdat +;;; (pkt #f) +;;; (dbload (make-hash-table)) ;; "dbfile.db" => queries/min +;;; (hostload #f) ;; normalized load ( 5min load / numcpus ) +;;; ) +;;; +;;; ;; dbdat +;;; ;; +;;; (defstruct dbdat +;;; (dbh #f) +;;; (fname #f) +;;; (write-access #f) +;;; (sths (make-hash-table)) ;; hash mapping query strings to handles +;;; ) +;;; +;;; ;; qdat +;;; ;; +;;; (defstruct qdat +;;; (writeq (make-queue)) +;;; (readq (make-queue)) +;;; (rwq (make-queue)) +;;; (logq (make-queue)) ;; do we need a queue for logging? yes, if we use sqlite3 db for logging +;;; (osshort (make-queue)) +;;; (oslong (make-queue)) +;;; (misc (make-queue)) ;; used for things like ping-full +;;; ) +;;; +;;; ;; calldat +;;; ;; +;;; (defstruct calldat +;;; (ctype 'dbwrite) +;;; (obj #f) ;; this would normally be an SQL statement e.g. SELECT, INSERT etc. +;;; (rtime (current-milliseconds))) +;;; +;;; ;; make it a global? Well, it is local to area module +;;; +;;; (define *pktspec* +;;; `((server (hostname . h) +;;; (port . p) +;;; (pid . i) +;;; (ipaddr . a) +;;; ) +;;; (data (hostname . h) ;; sender hostname +;;; (port . p) ;; sender port +;;; (ipaddr . a) ;; sender ip +;;; (hostkey . k) ;; sending host key - store info at server under this key +;;; (servkey . s) ;; server key - this needs to match at server end or reject the msg +;;; (format . f) ;; sb=serialized-base64, t=text, sx=sexpr, j=json +;;; (data . d) ;; base64 encoded slln data +;;; ))) +;;; +;;; ;; work item +;;; ;; +;;; (defstruct witem +;;; (rhost #f) ;; return host +;;; (ripaddr #f) ;; return ipaddr +;;; (rport #f) ;; return port +;;; (servkey #f) ;; the packet representing the client of this workitem, used by final send-message +;;; (rdat #f) ;; the request - usually an sql query, type is rdat +;;; (action #f) ;; the action: immediate, dbwrite, dbread,oslong, osshort +;;; (cookie #f) ;; cookie id for response +;;; (data #f) ;; the data payload, i.e. parameters +;;; (result #f) ;; the result from processing the data +;;; (caller #f)) ;; the calling peer according to rpc itself +;;; +;;; (define (trim-pktid pktid) +;;; (if (string? pktid) +;;; (substring pktid 0 4) +;;; "nopkt")) +;;; +;;; (define (any->number num) +;;; (cond +;;; ((number? num) num) +;;; ((string? num) (string->number num)) +;;; (else num))) +;;; +;;; (use trace) +;;; (trace-call-sites #t) +;;; +;;; ;;====================================================================== +;;; ;; D A T A B A S E H A N D L I N G +;;; ;;====================================================================== +;;; +;;; ;; look in dbhandles for a db, return it, else return #f +;;; ;; +;;; (define (get-dbh acfg fname) +;;; (let ((dbh-lst (hash-table-ref/default (area-dbhandles acfg) fname '()))) +;;; (if (null? dbh-lst) +;;; (begin +;;; ;; (print "opening db for " fname) +;;; (open-db acfg fname)) ;; Note that the handles get put back in the queue in the save-dbh calls +;;; (let ((rem-lst (cdr dbh-lst))) +;;; ;; (print "re-using saved connection for " fname) +;;; (hash-table-set! (area-dbhandles acfg) fname rem-lst) +;;; (car dbh-lst))))) +;;; +;;; (define (save-dbh acfg fname dbdat) +;;; ;; (print "saving dbh for " fname) +;;; (hash-table-set! (area-dbhandles acfg) fname (cons dbdat (hash-table-ref/default (area-dbhandles acfg) fname '())))) +;;; +;;; ;; open the database, if never before opened init it. put the handle in the +;;; ;; open db's hash table +;;; ;; returns: the dbdat +;;; ;; +;;; (define (open-db acfg fname) +;;; (let* ((fullname (conc (area-dbdir acfg) "/" fname)) +;;; (exists (file-exists? fullname)) +;;; (write-access (if exists +;;; (file-write-access? fullname) +;;; (file-write-access? (area-dbdir acfg)))) +;;; (db (sqlite3:open-database fullname)) +;;; (handler (sqlite3:make-busy-timeout 136000)) +;;; ) +;;; (sqlite3:set-busy-handler! db handler) +;;; (sqlite3:execute db "PRAGMA synchronous = 0;") +;;; (if (not exists) ;; need to init the db +;;; (if write-access +;;; (let ((isql (get-rsql acfg 'dbinitsql))) ;; get the init sql statements +;;; ;; (sqlite3:with-transaction +;;; ;; db +;;; ;; (lambda () +;;; (if isql +;;; (for-each +;;; (lambda (sql) +;;; (sqlite3:execute db sql)) +;;; isql))) +;;; (print "ERROR: no write access to " (area-dbdir acfg)))) +;;; (make-dbdat dbh: db fname: fname write-access: write-access))) +;;; +;;; ;; This is a low-level command to retrieve or to prepare, save and return a prepared statment +;;; ;; you must extract the db handle +;;; ;; +;;; (define (get-sth db cache stmt) +;;; (if (hash-table-exists? cache stmt) +;;; (begin +;;; ;; (print "Reusing cached stmt for " stmt) +;;; (hash-table-ref/default cache stmt #f)) +;;; (let ((sth (sqlite3:prepare db stmt))) +;;; (hash-table-set! cache stmt sth) +;;; ;; (print "prepared stmt for " stmt) +;;; sth))) +;;; +;;; ;; a little more expensive but does all the tedious deferencing - only use if you don't already +;;; ;; have dbdat and db sitting around +;;; ;; +;;; (define (full-get-sth acfg fname stmt) +;;; (let* ((dbdat (get-dbh acfg fname)) +;;; (db (dbdat-dbh dbdat)) +;;; (sths (dbdat-sths dbdat))) +;;; (get-sth db sths stmt))) +;;; +;;; ;; write to a db +;;; ;; acfg: area data +;;; ;; rdat: request data +;;; ;; hdat: (host . port) +;;; ;; +;;; ;; (define (dbwrite acfg rdat hdat data-in) +;;; ;; (let* ((dbname (car data-in)) +;;; ;; (dbdat (get-dbh acfg dbname)) +;;; ;; (db (dbdat-dbh dbdat)) +;;; ;; (sths (dbdat-sths dbdat)) +;;; ;; (stmt (calldat-obj rdat)) +;;; ;; (sth (get-sth db sths stmt)) +;;; ;; (data (cdr data-in))) +;;; ;; (print "dbname: " dbname " acfg: " acfg " rdat: " (calldat->alist rdat) " hdat: " hdat " data: " data) +;;; ;; (print "dbdat: " (dbdat->alist dbdat)) +;;; ;; (apply sqlite3:execute sth data) +;;; ;; (save-dbh acfg dbname dbdat) +;;; ;; #t +;;; ;; )) +;;; +;;; (define (finalize-all-db-handles acfg) +;;; (let* ((dbhandles (area-dbhandles acfg)) ;; dbhandles is hash of fname ==> dbdat +;;; (num 0)) +;;; (for-each +;;; (lambda (area-name) +;;; (print "Closing handles for " area-name) +;;; (let ((dbdats (hash-table-ref/default dbhandles area-name '()))) +;;; (for-each +;;; (lambda (dbdat) +;;; ;; first close all statement handles +;;; (for-each +;;; (lambda (sth) +;;; (sqlite3:finalize! sth) +;;; (set! num (+ num 1))) +;;; (hash-table-values (dbdat-sths dbdat))) +;;; ;; now close the dbh +;;; (set! num (+ num 1)) +;;; (sqlite3:finalize! (dbdat-dbh dbdat))) +;;; dbdats))) +;;; (hash-table-keys dbhandles)) +;;; (print "FINALIZED " num " dbhandles"))) +;;; +;;; ;;====================================================================== +;;; ;; W O R K Q U E U E H A N D L I N G +;;; ;;====================================================================== +;;; +;;; (define (register-db-as-mine acfg dbname) +;;; (let ((ht (area-dbs acfg))) +;;; (if (not (hash-table-ref/default ht dbname #f)) +;;; (hash-table-set! ht dbname (random 10000))))) +;;; +;;; (define (work-queue-add acfg fname witem) +;;; (let* ((work-queue-start (current-milliseconds)) +;;; (action (witem-action witem)) ;; NB the action is the index into the rdat actions +;;; (qdat (or (hash-table-ref/default (area-wqueues acfg) fname #f) +;;; (let ((newqdat (make-qdat))) +;;; (hash-table-set! (area-wqueues acfg) fname newqdat) +;;; newqdat))) +;;; (rdat (hash-table-ref/default (area-rtable acfg) action #f))) +;;; (if rdat +;;; (queue-add! +;;; (case (calldat-ctype rdat) +;;; ((dbwrite) (register-db-as-mine acfg fname)(qdat-writeq qdat)) +;;; ((dbread) (register-db-as-mine acfg fname)(qdat-readq qdat)) +;;; ((dbrw) (register-db-as-mine acfg fname)(qdat-rwq qdat)) +;;; ((oslong) (qdat-oslong qdat)) +;;; ((osshort) (qdat-osshort qdat)) +;;; ((full-ping) (qdat-misc qdat)) +;;; (else +;;; (print "ERROR: no queue for " action ". Adding to dbwrite queue.") +;;; (qdat-writeq qdat))) +;;; witem) +;;; (case action +;;; ((full-ping)(qdat-misc qdat)) +;;; (else +;;; (print "ERROR: No action " action " was registered")))) +;;; (sdbg> "work-queue-add" "queue-add" work-queue-start #f #f) +;;; #t)) ;; for now, simply return #t to indicate request got to the queue +;;; +;;; (define (doqueue acfg q fname dbdat dbh) +;;; ;; (print "doqueue: " fname) +;;; (let* ((start-time (current-milliseconds)) +;;; (qlen (queue-length q))) +;;; (if (> qlen 1) +;;; (print "Processing queue of length " qlen)) +;;; (let loop ((count 0) +;;; (responses '())) +;;; (let ((delta (- (current-milliseconds) start-time))) +;;; (if (or (queue-empty? q) +;;; (> delta 400)) ;; stop working on this queue after 400ms have passed +;;; (list count delta responses) ;; return count, delta and responses list +;;; (let* ((witem (queue-remove! q)) +;;; (action (witem-action witem)) +;;; (rdat (witem-rdat witem)) +;;; (stmt (calldat-obj rdat)) +;;; (sth (full-get-sth acfg fname stmt)) +;;; (ctype (calldat-ctype rdat)) +;;; (data (witem-data witem)) +;;; (cookie (witem-cookie witem))) +;;; ;; do the processing and save the result in witem-result +;;; (witem-result-set! +;;; witem +;;; (case ctype ;; action +;;; ((noblockwrite) ;; blind write, no ack of success returned +;;; (apply sqlite3:execute sth data) +;;; (sqlite3:last-insert-rowid dbh)) +;;; ((dbwrite) ;; blocking write +;;; (apply sqlite3:execute sth data) +;;; #t) +;;; ((dbread) ;; TODO: consider breaking this up and shipping in pieces for large query +;;; (apply sqlite3:map-row (lambda x x) sth data)) +;;; ((full-ping) 'full-ping) +;;; (else (print "Not ready for action " action) #f))) +;;; (loop (add1 count) +;;; (if cookie +;;; (cons witem responses) +;;; responses)))))))) +;;; +;;; ;; do up to 400ms of processing on each queue +;;; ;; - the work-queue-processor will allow the max 1200ms of work to complete but it will flag as overloaded +;;; ;; +;;; (define (process-db-queries acfg fname) +;;; (if (hash-table-exists? (area-wqueues acfg) fname) +;;; (let* ((process-db-queries-start-time (current-milliseconds)) +;;; (qdat (hash-table-ref/default (area-wqueues acfg) fname #f)) +;;; (queue-sym->queue (lambda (queue-sym) +;;; (case queue-sym ;; lookup the queue from qdat given a name (symbol) +;;; ((wqueue) (qdat-writeq qdat)) +;;; ((rqueue) (qdat-readq qdat)) +;;; ((rwqueue) (qdat-rwq qdat)) +;;; ((misc) (qdat-misc qdat)) +;;; (else #f)))) +;;; (dbdat (get-dbh acfg fname)) +;;; (dbh (if (dbdat? dbdat)(dbdat-dbh dbdat) #f)) +;;; (nowtime (current-seconds))) +;;; ;; handle the queues that require a transaction +;;; ;; +;;; (map ;; +;;; (lambda (queue-sym) +;;; ;; (print "processing queue " queue-sym) +;;; (let* ((queue (queue-sym->queue queue-sym))) +;;; (if (not (queue-empty? queue)) +;;; (let ((responses +;;; (sqlite3:with-transaction ;; todo - catch exceptions... +;;; dbh +;;; (lambda () +;;; (let* ((res (doqueue acfg queue fname dbdat dbh))) ;; this does the work! +;;; ;; (print "res=" res) +;;; (match res +;;; ((count delta responses) +;;; (update-stats acfg fname queue-sym delta count) +;;; (sdbg> "process-db-queries" "sqlite3-transaction" process-db-queries-start-time #f #f) +;;; responses) ;; return responses +;;; (else +;;; (print "ERROR: bad return data from doqueue " res))) +;;; ))))) +;;; ;; having completed the transaction, send the responses. +;;; ;; (print "INFO: sending " (length responses) " responses.") +;;; (let loop ((responses-left responses)) +;;; (cond +;;; ((null? responses-left) #t) +;;; (else +;;; (let* ((witem (car responses-left)) +;;; (response (cdr responses-left))) +;;; (call-deliver-response acfg (witem-ripaddr witem)(witem-rport witem) +;;; (witem-cookie witem)(witem-result witem))) +;;; (loop (cdr responses-left)))))) +;;; ))) +;;; '(wqueue rwqueue rqueue)) +;;; +;;; ;; handle misc queue +;;; ;; +;;; ;; (print "processing misc queue") +;;; (let ((queue (queue-sym->queue 'misc))) +;;; (doqueue acfg queue fname dbdat dbh)) +;;; ;; .... +;;; (save-dbh acfg fname dbdat) +;;; #t ;; just to let the tests know we got here +;;; ) +;;; #f ;; nothing processed +;;; )) +;;; +;;; ;; run all queues in parallel per db but sequentially per queue for that db. +;;; ;; - process the queues every 500 or so ms +;;; ;; - allow for long running queries to continue but all other activities for that +;;; ;; db will be blocked. +;;; ;; +;;; (define (work-queue-processor acfg) +;;; (let* ((threads (make-hash-table))) ;; fname => thread +;;; (let loop ((fnames (hash-table-keys (area-wqueues acfg))) +;;; (target-time (+ (current-milliseconds) 50))) +;;; ;;(if (not (null? fnames))(print "Processing for these databases: " fnames)) +;;; (for-each +;;; (lambda (fname) +;;; ;; (print "processing for " fname) +;;; ;;(process-db-queries acfg fname)) +;;; (let ((th (hash-table-ref/default threads fname #f))) +;;; (if (and th (not (member (thread-state th) '(dead terminated)))) +;;; (begin +;;; (print "WARNING: worker thread for " fname " is taking a long time.") +;;; (print "Thread is in state " (thread-state th))) +;;; (let ((th1 (make-thread (lambda () +;;; ;; (catch-and-dump +;;; ;; (lambda () +;;; ;; (print "Process queries for " fname) +;;; (let ((start-time (current-milliseconds))) +;;; (process-db-queries acfg fname) +;;; ;; (thread-sleep! 0.01) ;; need the thread to take at least some time +;;; (hash-table-delete! threads fname)) ;; no mutexes? +;;; fname) +;;; "th1"))) ;; )) +;;; (hash-table-set! threads fname th1) +;;; (thread-start! th1))))) +;;; fnames) +;;; ;; (thread-sleep! 0.1) ;; give the threads some time to process requests +;;; ;; burn time until 400ms is up +;;; (let ((now-time (current-milliseconds))) +;;; (if (< now-time target-time) +;;; (let ((delta (- target-time now-time))) +;;; (thread-sleep! (/ delta 1000))))) +;;; (loop (hash-table-keys (area-wqueues acfg)) +;;; (+ (current-milliseconds) 50))))) +;;; +;;; ;;====================================================================== +;;; ;; S T A T S G A T H E R I N G +;;; ;;====================================================================== +;;; +;;; (defstruct stat +;;; (qcount-avg 0) ;; coarse running average +;;; (qtime-avg 0) ;; coarse running average +;;; (qcount 0) ;; total +;;; (qtime 0) ;; total +;;; (last-qcount 0) ;; last +;;; (last-qtime 0) ;; last +;;; (dbs '()) ;; list of db files handled by this node +;;; (when 0)) ;; when the last query happened - seconds +;;; +;;; +;;; (define (update-stats acfg fname bucket duration numqueries) +;;; (let* ((key fname) ;; for now do not use bucket. Was: (conc fname "-" bucket)) ;; lazy but good enough +;;; (stats (or (hash-table-ref/default (area-stats acfg) key #f) +;;; (let ((newstats (make-stat))) +;;; (hash-table-set! (area-stats acfg) key newstats) +;;; newstats)))) +;;; ;; when the last query happended (used to remove the fname from the active list) +;;; (stat-when-set! stats (current-seconds)) +;;; ;; last values +;;; (stat-last-qcount-set! stats numqueries) +;;; (stat-last-qtime-set! stats duration) +;;; ;; total over process lifetime +;;; (stat-qcount-set! stats (+ (stat-qcount stats) numqueries)) +;;; (stat-qtime-set! stats (+ (stat-qtime stats) duration)) +;;; ;; coarse average +;;; (stat-qcount-avg-set! stats (/ (+ (stat-qcount-avg stats) numqueries) 2)) +;;; (stat-qtime-avg-set! stats (/ (+ (stat-qtime-avg stats) duration) 2)) +;;; +;;; ;; here is where we add the stats for a given dbfile +;;; (if (not (member fname (stat-dbs stats))) +;;; (stat-dbs-set! stats (cons fname (stat-dbs stats)))) +;;; +;;; )) +;;; +;;; ;;====================================================================== +;;; ;; S E R V E R S T U F F +;;; ;;====================================================================== +;;; +;;; ;; this does NOT return! +;;; ;; +;;; (define (find-free-port-and-open acfg) +;;; (let ((port (or (area-port acfg) 3200))) +;;; (handle-exceptions +;;; exn +;;; (begin +;;; (print "INFO: cannot bind to port " (rpc:default-server-port) ", trying next port") +;;; (area-port-set! acfg (+ port 1)) +;;; (find-free-port-and-open acfg)) +;;; (rpc:default-server-port port) +;;; (area-port-set! acfg port) +;;; (tcp-read-timeout 120000) +;;; ;; ((rpc:make-server (tcp-listen port)) #t) +;;; (tcp-listen (rpc:default-server-port) +;;; )))) +;;; +;;; ;; register this node by putting a packet into the pkts dir. +;;; ;; look for other servers +;;; ;; contact other servers and compile list of servers +;;; ;; there are two types of server +;;; ;; main servers - dashboards, runners and dedicated servers - need pkt +;;; ;; passive servers - test executers, step calls, list-runs - no pkt +;;; ;; +;;; (define (register-node acfg hostip port-num) +;;; ;;(mutex-lock! (area-mutex acfg)) +;;; (let* ((server-type (area-server-type acfg)) ;; auto, main, passive (no pkt created) +;;; (best-ip (or hostip (get-my-best-address))) +;;; (mtdir (area-dbdir acfg)) +;;; (pktdir (area-pktsdir acfg))) ;; conc mtdir "/.server-pkts"))) +;;; (print "Registering node " best-ip ":" port-num) +;;; (if (not mtdir) ;; require a home for this node to put or find databases +;;; #f +;;; (begin +;;; (if (not (directory? pktdir))(create-directory pktdir)) +;;; ;; server is started, now create pkt if needed +;;; (print "Starting server in " server-type " mode with port " port-num) +;;; (if (member server-type '(auto main)) ;; TODO: if auto, count number of servers registers, if > 3 then don't put out a pkt +;;; (begin +;;; (area-pktid-set! acfg +;;; (write-alist->pkt +;;; pktdir +;;; `((hostname . ,(get-host-name)) +;;; (ipaddr . ,best-ip) +;;; (port . ,port-num) +;;; (pid . ,(current-process-id))) +;;; pktspec: *pktspec* +;;; ptype: 'server)) +;;; (area-pktfile-set! acfg (conc pktdir "/" (area-pktid acfg) ".pkt")))) +;;; (area-port-set! acfg port-num) +;;; #;(mutex-unlock! (area-mutex acfg)))))) +;;; +;;; (define *cookie-seqnum* 0) +;;; (define (make-cookie key) +;;; (set! *cookie-seqnum* (add1 *cookie-seqnum*)) +;;; ;;(print "MAKE COOKIE CALLED -- on "servkey"-"*cookie-seqnum*) +;;; (conc key "-" *cookie-seqnum*) +;;; ) +;;; +;;; ;; dispatch locally if possible +;;; ;; +;;; (define (call-deliver-response acfg ipaddr port cookie data) +;;; (if (and (equal? (area-myaddr acfg) ipaddr) +;;; (equal? (area-port acfg) port)) +;;; (deliver-response acfg cookie data) +;;; ((rpc:procedure 'response ipaddr port) cookie data))) +;;; +;;; (define (deliver-response acfg cookie data) +;;; (let ((deliver-response-start (current-milliseconds))) +;;; (thread-start! (make-thread +;;; (lambda () +;;; (let loop ((tries-left 5)) +;;; ;;(print "TOP OF DELIVER_RESPONSE LOOP; triesleft="tries-left) +;;; ;;(pp (hash-table->alist (area-cookie2mbox acfg))) +;;; (let* ((mbox (hash-table-ref/default (area-cookie2mbox acfg) cookie #f))) +;;; (cond +;;; ((eq? 0 tries-left) +;;; (print "ulex:deliver-response: I give up. Mailbox never appeared. cookie="cookie) +;;; ) +;;; (mbox +;;; ;;(print "got mbox="mbox" got data="data" send.") +;;; (mailbox-send! mbox data)) +;;; (else +;;; ;;(print "no mbox yet. look for "cookie) +;;; (thread-sleep! (/ (- 6 tries-left) 10)) +;;; (loop (sub1 tries-left)))))) +;;; ;; (debug-pp (list (conc "ulex:deliver-response took " (- (current-milliseconds) deliver-response-start) " ms, cookie=" cookie " data=") data)) +;;; (sdbg> "deliver-response" "mailbox-send" deliver-response-start #f #f cookie) +;;; ) +;;; (conc "deliver-response thread for cookie="cookie)))) +;;; #t) +;;; +;;; ;; action: +;;; ;; immediate - quick actions, no need to put in queues +;;; ;; dbwrite - put in dbwrite queue +;;; ;; dbread - put in dbread queue +;;; ;; oslong - os actions, e.g. du, that could take a long time +;;; ;; osshort - os actions that should be quick, e.g. df +;;; ;; +;;; (define (request acfg from-ipaddr from-port servkey action cookie fname params) ;; std-peer-handler +;;; ;; NOTE: Use rpc:current-peer for getting return address +;;; (let* ((std-peer-handler-start (current-milliseconds)) +;;; ;; (raw-data (alist-ref 'data dat)) +;;; (rdat (hash-table-ref/default +;;; (area-rtable acfg) action #f)) ;; this looks up the sql query or other details indexed by the action +;;; (witem (make-witem ripaddr: from-ipaddr ;; rhost: from-host +;;; rport: from-port action: action +;;; rdat: rdat cookie: cookie +;;; servkey: servkey data: params ;; TODO - rename data to params +;;; caller: (rpc:current-peer)))) +;;; (if (not (equal? servkey (area-pktid acfg))) +;;; `(#f . ,(conc "I don't know you servkey=" servkey ", pktid=" (area-pktid acfg))) ;; immediately return this +;;; (let* ((ctype (if rdat +;;; (calldat-ctype rdat) ;; is this necessary? these should be identical +;;; action))) +;;; (sdbg> "std-peer-handler" "immediate" std-peer-handler-start #f #f) +;;; (case ctype +;;; ;; (dbwrite acfg rdat (cons from-ipaddr from-port) data))) +;;; ((full-ping) `(#t "ack to full ping" ,(work-queue-add acfg fname witem) ,cookie)) +;;; ((response) `(#t "ack from requestor" ,(deliver-response acfg fname params))) +;;; ((dbwrite) `(#t "db write submitted" ,(work-queue-add acfg fname witem) ,cookie)) +;;; ((dbread) `(#t "db read submitted" ,(work-queue-add acfg fname witem) ,cookie )) +;;; ((dbrw) `(#t "db read/write submitted" ,cookie)) +;;; ((osshort) `(#t "os short submitted" ,cookie)) +;;; ((oslong) `(#t "os long submitted" ,cookie)) +;;; (else `(#f "unrecognised action" ,ctype))))))) +;;; +;;; ;; Call this to start the actual server +;;; ;; +;;; ;; start_server +;;; ;; +;;; ;; mode: ' +;;; ;; handler: proc which takes pktrecieved as argument +;;; ;; +;;; +;;; (define (start-server acfg) +;;; (let* ((conn (find-free-port-and-open acfg)) +;;; (port (area-port acfg))) +;;; (rpc:publish-procedure! +;;; 'delist-db +;;; (lambda (fname) +;;; (hash-table-delete! (area-dbs acfg) fname))) +;;; (rpc:publish-procedure! +;;; 'calling-addr +;;; (lambda () +;;; (rpc:current-peer))) +;;; (rpc:publish-procedure! +;;; 'ping +;;; (lambda ()(real-ping acfg))) +;;; (rpc:publish-procedure! +;;; 'request +;;; (lambda (from-addr from-port servkey action cookie dbname params) +;;; (request acfg from-addr from-port servkey action cookie dbname params))) +;;; (rpc:publish-procedure! +;;; 'response +;;; (lambda (cookie res-dat) +;;; (deliver-response acfg cookie res-dat))) +;;; (area-ready-set! acfg #t) +;;; (area-conn-set! acfg conn) +;;; ((rpc:make-server conn) #f)));; ((tcp-listen (rpc:default-server-port)) #t) +;;; +;;; +;;; (define (launch acfg) ;; #!optional (proc std-peer-handler)) +;;; (print "starting launch") +;;; (update-known-servers acfg) ;; gotta do this on every start (thus why limit number of publicised servers) +;;; #;(let ((original-handler (current-exception-handler))) ;; is th +;;; (lambda (exception) +;;; (server-exit-procedure) +;;; (original-handler exception))) +;;; (on-exit (lambda () +;;; (shutdown acfg))) ;; (finalize-all-db-handles acfg))) +;;; ;; set up the rpc handler +;;; (let* ((th1 (make-thread +;;; (lambda ()(start-server acfg)) +;;; "server thread")) +;;; (th2 (make-thread +;;; (lambda () +;;; (print "th2 starting") +;;; (let loop () +;;; (work-queue-processor acfg) +;;; (print "work-queue-processor crashed!") +;;; (loop))) +;;; "work queue thread"))) +;;; (thread-start! th1) +;;; (thread-start! th2) +;;; (let loop () +;;; (thread-sleep! 0.025) +;;; (if (area-ready acfg) +;;; #t +;;; (loop))) +;;; ;; attempt to fix my address +;;; (let* ((all-addr (get-all-ips-sorted))) ;; could use (tcp-addresses conn)? +;;; (let loop ((rem-addrs all-addr)) +;;; (if (null? rem-addrs) +;;; (begin +;;; (print "ERROR: Failed to figure out the ip address of myself as a server. Giving up.") +;;; (exit 1)) ;; BUG Changeme to raising an exception +;;; +;;; (let* ((addr (car rem-addrs)) +;;; (good-addr (handle-exceptions +;;; exn +;;; #f +;;; ((rpc:procedure 'calling-addr addr (area-port acfg)))))) +;;; (if good-addr +;;; (begin +;;; (print "Got good-addr of " good-addr) +;;; (area-myaddr-set! acfg good-addr)) +;;; (loop (cdr rem-addrs))))))) +;;; (register-node acfg (area-myaddr acfg)(area-port acfg)) +;;; (print "INFO: Server started on " (area-myaddr acfg) ":" (area-port acfg)) +;;; ;; (update-known-servers acfg) ;; gotta do this on every start (thus why limit number of publicised servers) +;;; )) +;;; +;;; (define (clear-server-pkt acfg) +;;; (let ((pktf (area-pktfile acfg))) +;;; (if pktf (delete-file* pktf)))) +;;; +;;; (define (shutdown acfg) +;;; (let (;;(conn (area-conn acfg)) +;;; (pktf (area-pktfile acfg)) +;;; (port (area-port acfg))) +;;; (if pktf (delete-file* pktf)) +;;; (send-all "imshuttingdown") +;;; ;; (rpc:close-all-connections!) ;; don't know if this is actually needed +;;; (finalize-all-db-handles acfg))) +;;; +;;; (define (send-all msg) +;;; #f) +;;; +;;; ;; given a area record look up all the packets +;;; ;; +;;; (define (get-all-server-pkts acfg) +;;; (let ((all-pkt-files (glob (conc (area-pktsdir acfg) "/*.pkt")))) +;;; (map (lambda (pkt-file) +;;; (read-pkt->alist pkt-file pktspec: *pktspec*)) +;;; all-pkt-files))) +;;; +;;; #;((Z . "9a0212302295a19610d5796fce0370fa130758e9") +;;; (port . "34827") +;;; (pid . "28748") +;;; (hostname . "zeus") +;;; (T . "server") +;;; (D . "1549427032.0")) +;;; +;;; #;(define (get-my-best-address) +;;; (let ((all-my-addresses (get-all-ips))) ;; (vector->list (hostinfo-addresses (hostname->hostinfo (get-host-name)))))) +;;; (cond +;;; ((null? all-my-addresses) +;;; (get-host-name)) ;; no interfaces? +;;; ((eq? (length all-my-addresses) 1) +;;; (ip->string (car all-my-addresses))) ;; only one to choose from, just go with it +;;; (else +;;; (ip->string (car (filter (lambda (x) ;; take any but 127. +;;; (not (eq? (u8vector-ref x 0) 127))) +;;; all-my-addresses))))))) +;;; +;;; ;; whoami? I am my pkt +;;; ;; +;;; (define (whoami? acfg) +;;; (hash-table-ref/default (area-hosts acfg)(area-pktid acfg) #f)) +;;; +;;; ;;====================================================================== +;;; ;; "Client side" operations +;;; ;;====================================================================== +;;; +;;; (define (safe-call call-key host port . params) +;;; (handle-exceptions +;;; exn +;;; (begin +;;; (print "Call " call-key " to " host ":" port " failed") +;;; #f) +;;; (apply (rpc:procedure call-key host port) params))) +;;; +;;; ;; ;; convert to/from string / sexpr +;;; ;; +;;; ;; (define (string->sexpr str) +;;; ;; (if (string? str) +;;; ;; (with-input-from-string str read) +;;; ;; str)) +;;; ;; +;;; ;; (define (sexpr->string s) +;;; ;; (with-output-to-string (lambda ()(write s)))) +;;; +;;; ;; is the server alive? +;;; ;; +;;; (define (ping acfg host port) +;;; (let* ((myaddr (area-myaddr acfg)) +;;; (myport (area-port acfg)) +;;; (start-time (current-milliseconds)) +;;; (res (if (and (equal? myaddr host) +;;; (equal? myport port)) +;;; (real-ping acfg) +;;; ((rpc:procedure 'ping host port))))) +;;; (cons (- (current-milliseconds) start-time) +;;; res))) +;;; +;;; ;; returns ( ipaddr port alist-fname=>randnum ) +;;; (define (real-ping acfg) +;;; `(,(area-myaddr acfg) ,(area-port acfg) ,(get-host-stats acfg))) +;;; +;;; ;; is the server alive AND the queues processing? +;;; ;; +;;; #;(define (full-ping acfg servpkt) +;;; (let* ((start-time (current-milliseconds)) +;;; (res (send-message acfg servpkt '(full-ping) 'full-ping))) +;;; (cons (- (current-milliseconds) start-time) +;;; res))) ;; (equal? res "got ping")))) +;;; +;;; +;;; ;; look up all pkts and get the server id (the hash), port, host/ip +;;; ;; store this info in acfg +;;; ;; return the number of responsive servers found +;;; ;; +;;; ;; DO NOT VERIFY THAT THE SERVER IS ALIVE HERE. This is called at times where the current server is not yet alive and cannot ping itself +;;; ;; +;;; (define (update-known-servers acfg) +;;; ;; readll all pkts +;;; ;; foreach pkt; if it isn't me ping the server; if alive, add to hosts hash, else rm the pkt +;;; (let* ((start-time (current-milliseconds)) +;;; (all-pkts (delete-duplicates +;;; (append (get-all-server-pkts acfg) +;;; (hash-table-values (area-hosts acfg))))) +;;; (hostshash (area-hosts acfg)) +;;; (my-id (area-pktid acfg)) +;;; (pktsdir (area-pktsdir acfg)) ;; needed to remove pkts from non-responsive servers +;;; (numsrvs 0) +;;; (delpkt (lambda (pktsdir sid) +;;; (print "clearing out server " sid) +;;; (delete-file* (conc pktsdir "/" sid ".pkt")) +;;; (hash-table-delete! hostshash sid)))) +;;; (area-last-srvup-set! acfg (current-seconds)) +;;; (for-each +;;; (lambda (servpkt) +;;; (if (list? servpkt) +;;; ;; (pp servpkt) +;;; (let* ((shost (alist-ref 'ipaddr servpkt)) +;;; (sport (any->number (alist-ref 'port servpkt))) +;;; (res (handle-exceptions +;;; exn +;;; (begin +;;; ;; (print "INFO: bad server on " shost ":" sport) +;;; #f) +;;; (ping acfg shost sport))) +;;; (sid (alist-ref 'Z servpkt)) ;; Z code is our name for the server +;;; (url (conc shost ":" sport)) +;;; ) +;;; #;(if (or (not res) +;;; (null? res)) +;;; (begin +;;; (print "STRANGE: ping of " url " gave " res))) +;;; +;;; ;; (print "Got " res " from " shost ":" sport) +;;; (match res +;;; ((qduration . payload) +;;; ;; (print "Server pkt:" (alist-ref 'ipaddr servpkt) ":" (alist-ref 'port servpkt) +;;; ;; (if payload +;;; ;; "Success" "Fail")) +;;; (match payload +;;; ((host port stats) +;;; ;; (print "From " host ":" port " got stats: " stats) +;;; (if (and host port stats) +;;; (let ((url (conc host ":" port))) +;;; (hash-table-set! hostshash sid servpkt) +;;; ;; store based on host:port +;;; (hash-table-set! (area-hoststats acfg) sid stats)) +;;; (print "missing data from the server, not sure what that means!")) +;;; (set! numsrvs (+ numsrvs 1))) +;;; (#f +;;; (print "Removing pkt " sid " due to #f from server or failed ping") +;;; (delpkt pktsdir sid)) +;;; (else +;;; (print "Got ")(pp res)(print " from server ")(pp servpkt) " but response did not match (#f/#t . msg)"))) +;;; (else +;;; ;; here we delete the pkt - can't reach the server, remove it +;;; ;; however this logic is inadequate. we should mark the server as checked +;;; ;; and not good, if it happens a second time - then remove the pkt +;;; ;; or something similar. I.e. don't be too quick to assume the server is wedged or dead +;;; ;; could be it is simply too busy to reply +;;; (let ((bad-pings (hash-table-ref/default (area-health acfg) url 0))) +;;; (if (> bad-pings 1) ;; two bad pings - remove pkt +;;; (begin +;;; (print "INFO: " bad-pings " bad responses from " url ", deleting pkt " sid) +;;; (delpkt pktsdir sid)) +;;; (begin +;;; (print "INFO: " bad-pings " bad responses from " shost ":" sport " not deleting pkt yet") +;;; (hash-table-set! (area-health acfg) +;;; url +;;; (+ (hash-table-ref/default (area-health acfg) url 0) 1)) +;;; )) +;;; )))) +;;; ;; servpkt is not actually a pkt? +;;; (begin +;;; (print "Bad pkt " servpkt)))) +;;; all-pkts) +;;; (sdbg> "update-known-servers" "end" start-time #f #f " found " numsrvs +;;; " servers, pkts: " (map (lambda (p) +;;; (alist-ref 'Z p)) +;;; all-pkts)) +;;; numsrvs)) +;;; +;;; (defstruct srvstat +;;; (numfiles 0) ;; number of db files handled by this server - subtract 1 for the db being currently looked at +;;; (randnum #f) ;; tie breaker number assigned to by the server itself - applies only to the db under consideration +;;; (pkt #f)) ;; the server pkt +;;; +;;; ;;(define (srv->srvstat srvpkt) +;;; +;;; ;; Get the server best for given dbname and key +;;; ;; +;;; ;; NOTE: key is not currently used. The key points to the kind of query, this may be useful for directing read-only queries. +;;; ;; +;;; (define (get-best-server acfg dbname key) +;;; (let* (;; (servers (hash-table-values (area-hosts acfg))) +;;; (servers (area-hosts acfg)) +;;; (skeys (sort (hash-table-keys servers) string>=?)) ;; a stable listing +;;; (start-time (current-milliseconds)) +;;; (srvstats (make-hash-table)) ;; srvid => srvstat +;;; (url (conc (area-myaddr acfg) ":" (area-port acfg)))) +;;; ;; (print "scores for " dbname ": " (map (lambda (k)(cons k (calc-server-score acfg dbname k))) skeys)) +;;; (if (null? skeys) +;;; (if (> (update-known-servers acfg) 0) +;;; (get-best-server acfg dbname key) ;; some risk of infinite loop here, TODO add try counter +;;; (begin +;;; (print "ERROR: no server found!") ;; since this process is also a server this should never happen +;;; #f)) +;;; (begin +;;; ;; (print "in get-best-server with skeys=" skeys) +;;; (if (> (- (current-seconds) (area-last-srvup acfg)) 10) +;;; (begin +;;; (update-known-servers acfg) +;;; (sdbg> "get-best-server" "update-known-servers" start-time #f #f))) +;;; +;;; ;; for each server look at the list of dbfiles, total number of dbs being handled +;;; ;; and the rand number, save the best host +;;; ;; also do a delist-db for each server dbfile not used +;;; (let* ((best-server #f) +;;; (servers-to-delist (make-hash-table))) +;;; (for-each +;;; (lambda (srvid) +;;; (let* ((server (hash-table-ref/default servers srvid #f)) +;;; (stats (hash-table-ref/default (area-hoststats acfg) srvid '(())))) +;;; ;; (print "stats: " stats) +;;; (if server +;;; (let* ((dbweights (car stats)) +;;; (srvload (length (filter (lambda (x)(not (equal? dbname (car x)))) dbweights))) +;;; (dbrec (alist-ref dbname dbweights equal?)) ;; get the pair with fname . randscore +;;; (randnum (if dbrec +;;; dbrec ;; (cdr dbrec) +;;; 0))) +;;; (hash-table-set! srvstats srvid (make-srvstat numfiles: srvload randnum: randnum pkt: server)))))) +;;; skeys) +;;; +;;; (let* ((sorted (sort (hash-table-values srvstats) +;;; (lambda (a b) +;;; (let ((numfiles-a (srvstat-numfiles a)) +;;; (numfiles-b (srvstat-numfiles b)) +;;; (randnum-a (srvstat-randnum a)) +;;; (randnum-b (srvstat-randnum b))) +;;; (if (< numfiles-a numfiles-b) ;; Note, I don't think adding an offset works here. Goal was only move file handling to a different server if it has 2 less +;;; #t +;;; (if (and (equal? numfiles-a numfiles-b) +;;; (< randnum-a randnum-b)) +;;; #t +;;; #f)))))) +;;; (best (if (null? sorted) +;;; (begin +;;; (print "ERROR: should never be null due to self as server.") +;;; #f) +;;; (srvstat-pkt (car sorted))))) +;;; #;(print "SERVER(" url "): " dbname ": " (map (lambda (srv) +;;; (let ((p (srvstat-pkt srv))) +;;; (conc (alist-ref 'ipaddr p) ":" (alist-ref 'port p) +;;; "(" (srvstat-numfiles srv)","(srvstat-randnum srv)")"))) +;;; sorted)) +;;; best)))))) +;;; +;;; ;; send out an "I'm about to exit notice to all known servers" +;;; ;; +;;; (define (death-imminent acfg) +;;; '()) +;;; +;;; ;;====================================================================== +;;; ;; U L E X - T H E I N T E R E S T I N G S T U F F ! ! +;;; ;;====================================================================== +;;; +;;; ;; register a handler +;;; ;; NOTES: +;;; ;; dbinitsql is reserved for a list of sql statements for initializing the db +;;; ;; dbinitfn is reserved for a db init function, if exists called after dbinitsql +;;; ;; +;;; (define (register acfg key obj #!optional (ctype 'dbwrite)) +;;; (let ((ht (area-rtable acfg))) +;;; (if (hash-table-exists? ht key) +;;; (print "WARNING: redefinition of entry " key)) +;;; (hash-table-set! ht key (make-calldat obj: obj ctype: ctype)))) +;;; +;;; ;; usage: register-batch acfg '((key1 . sql1) (key2 . sql2) ... ) +;;; ;; NB// obj is often an sql query +;;; ;; +;;; (define (register-batch acfg ctype data) +;;; (let ((ht (area-rtable acfg))) +;;; (map (lambda (dat) +;;; (hash-table-set! ht (car dat)(make-calldat obj: (cdr dat) ctype: ctype))) +;;; data))) +;;; +;;; (define (initialize-area-calls-from-specfile area specfile) +;;; (let* ((callspec (with-input-from-file specfile read ))) +;;; (for-each (lambda (group) +;;; (register-batch +;;; area +;;; (car group) +;;; (cdr group))) +;;; callspec))) +;;; +;;; ;; get-rentry +;;; ;; +;;; (define (get-rentry acfg key) +;;; (hash-table-ref/default (area-rtable acfg) key #f)) +;;; +;;; (define (get-rsql acfg key) +;;; (let ((cdat (get-rentry acfg key))) +;;; (if cdat +;;; (calldat-obj cdat) +;;; #f))) +;;; +;;; +;;; +;;; ;; blocking call: +;;; ;; client server +;;; ;; ------ ------ +;;; ;; call() +;;; ;; send-message() +;;; ;; nmsg-send() +;;; ;; nmsg-receive() +;;; ;; nmsg-respond(ack,cookie) +;;; ;; ack, cookie +;;; ;; mbox-thread-wait(cookie) +;;; ;; nmsg-send(client,cookie,result) +;;; ;; nmsg-respond(ack) +;;; ;; return result +;;; ;; +;;; ;; reserved action: +;;; ;; 'immediate +;;; ;; 'dbinitsql +;;; ;; +;;; (define (call acfg dbname action params #!optional (count 0)) +;;; (let* ((call-start-time (current-milliseconds)) +;;; (srv (get-best-server acfg dbname action)) +;;; (post-get-start-time (current-milliseconds)) +;;; (rdat (hash-table-ref/default (area-rtable acfg) action #f)) +;;; (myid (trim-pktid (area-pktid acfg))) +;;; (srvid (trim-pktid (alist-ref 'Z srv))) +;;; (cookie (make-cookie myid))) +;;; (sdbg> "call" "get-best-server" call-start-time #f call-start-time " from: " myid " to server: " srvid " for " dbname " action: " action " params: " params " rdat: " rdat) +;;; (print "INFO: call to " (alist-ref 'ipaddr srv) ":" (alist-ref 'port srv) " from " (area-myaddr acfg) ":" (area-port acfg) " for " dbname) +;;; (if (and srv rdat) ;; need both to dispatch a request +;;; (let* ((ripaddr (alist-ref 'ipaddr srv)) +;;; (rsrvid (alist-ref 'Z srv)) +;;; (rport (any->number (alist-ref 'port srv))) +;;; (res-full (if (and (equal? ripaddr (area-myaddr acfg)) +;;; (equal? rport (area-port acfg))) +;;; (request acfg ripaddr rport (area-pktid acfg) action cookie dbname params) +;;; (safe-call 'request ripaddr rport +;;; (area-myaddr acfg) +;;; (area-port acfg) +;;; #;(area-pktid acfg) +;;; rsrvid +;;; action cookie dbname params)))) +;;; ;; (print "res-full: " res-full) +;;; (match res-full +;;; ((response-ok response-msg rem ...) +;;; (let* ((send-message-time (current-milliseconds)) +;;; ;; (match res-full +;;; ;; ((response-ok response-msg) +;;; ;; (response-ok (car res-full)) +;;; ;; (response-msg (cadr res-full) +;;; ) +;;; ;; (res (take res-full 3))) ;; ctype == action, TODO: converge on one term <<=== what was this? BUG +;;; ;; (print "ulex:call: send-message took " (- send-message-time post-get-start-time) " ms params=" params) +;;; (sdbg> "call" "send-message" post-get-start-time #f call-start-time) +;;; (cond +;;; ((not response-ok) #f) +;;; ((member response-msg '("db read submitted" "db write submitted")) +;;; (let* ((cookie-id (cadddr res-full)) +;;; (mbox (make-mailbox)) +;;; (mbox-time (current-milliseconds))) +;;; (hash-table-set! (area-cookie2mbox acfg) cookie-id mbox) +;;; (let* ((mbox-timeout-secs 20) +;;; (mbox-timeout-result 'MBOX_TIMEOUT) +;;; (res (mailbox-receive! mbox mbox-timeout-secs mbox-timeout-result)) +;;; (mbox-receive-time (current-milliseconds))) +;;; (hash-table-delete! (area-cookie2mbox acfg) cookie-id) +;;; (sdbg> "call" "mailbox-receive" mbox-time #f call-start-time " from: " myid " to server: " srvid " for " dbname) +;;; ;; (print "ulex:call mailbox-receive took " (- mbox-receive-time mbox-time) "ms params=" params) +;;; res))) +;;; (else +;;; (print "Unhandled response \""response-msg"\"") +;;; #f)) +;;; ;; depending on what action (i.e. ctype) is we will block here waiting for +;;; ;; all the data (mechanism to be determined) +;;; ;; +;;; ;; if res is a "working on it" then wait +;;; ;; wait for result +;;; ;; mailbox thread wait on +;;; +;;; ;; if res is a "can't help you" then try a different server +;;; ;; if res is a "ack" (e.g. for one-shot requests) then return res +;;; )) +;;; (else +;;; (if (< count 10) +;;; (let* ((url (conc (alist-ref 'ipaddr srv) ":" (alist-ref 'port srv)))) +;;; (thread-sleep! 1) +;;; (print "ERROR: Bad result from " url ", dbname: " dbname ", action: " action ", params: " params ". Trying again in 1 second.") +;;; (call acfg dbname action params (+ count 1))) +;;; (begin +;;; (error (conc "ERROR: " count " tries, still have improper response res-full=" res-full))))))) +;;; (begin +;;; (if (not rdat) +;;; (print "ERROR: action " action " not registered.") +;;; (if (< count 10) +;;; (begin +;;; (thread-sleep! 1) +;;; (area-hosts-set! acfg (make-hash-table)) ;; clear out all known hosts +;;; (print "ERROR: no server found, srv=" srv ", trying again in 1 seconds") +;;; (call acfg dbname action params (+ count 1))) +;;; (begin +;;; (error (conc "ERROR: no server found after 10 tries, srv=" srv ", giving up.")) +;;; #;(error "No server available")))))))) +;;; +;;; +;;; ;;====================================================================== +;;; ;; U T I L I T I E S +;;; ;;====================================================================== +;;; +;;; ;; get a signature for identifing this process +;;; ;; +;;; (define (get-process-signature) +;;; (cons (get-host-name)(current-process-id))) +;;; +;;; ;;====================================================================== +;;; ;; S Y S T E M S T U F F +;;; ;;====================================================================== +;;; +;;; ;; get normalized cpu load by reading from /proc/loadavg and +;;; ;; /proc/cpuinfo return all three values and the number of real cpus +;;; ;; and the number of threads returns alist '((adj-cpu-load +;;; ;; . normalized-proc-load) ... etc. keys: adj-proc-load, +;;; ;; adj-core-load, 1m-load, 5m-load, 15m-load +;;; ;; +;;; (define (get-normalized-cpu-load) +;;; (let ((res (get-normalized-cpu-load-raw)) +;;; (default `((adj-proc-load . 2) ;; there is no right answer +;;; (adj-core-load . 2) +;;; (1m-load . 2) +;;; (5m-load . 0) ;; causes a large delta - thus causing default of throttling if stuff goes wrong +;;; (15m-load . 0) +;;; (proc . 1) +;;; (core . 1) +;;; (phys . 1) +;;; (error . #t)))) +;;; (cond +;;; ((and (list? res) +;;; (> (length res) 2)) +;;; res) +;;; ((eq? res #f) default) ;; add messages? +;;; ((eq? res #f) default) ;; this would be the #eof +;;; (else default)))) +;;; +;;; (define (get-normalized-cpu-load-raw) +;;; (let* ((actual-host (get-host-name))) ;; #f is localhost +;;; (let ((data (append +;;; (with-input-from-file "/proc/loadavg" read-lines) +;;; (with-input-from-file "/proc/cpuinfo" read-lines) +;;; (list "end"))) +;;; (load-rx (regexp "^([\\d\\.]+)\\s+([\\d\\.]+)\\s+([\\d\\.]+)\\s+.*$")) +;;; (proc-rx (regexp "^processor\\s+:\\s+(\\d+)\\s*$")) +;;; (core-rx (regexp "^core id\\s+:\\s+(\\d+)\\s*$")) +;;; (phys-rx (regexp "^physical id\\s+:\\s+(\\d+)\\s*$")) +;;; (max-num (lambda (p n)(max (string->number p) n)))) +;;; ;; (print "data=" data) +;;; (if (null? data) ;; something went wrong +;;; #f +;;; (let loop ((hed (car data)) +;;; (tal (cdr data)) +;;; (loads #f) +;;; (proc-num 0) ;; processor includes threads +;;; (phys-num 0) ;; physical chip on motherboard +;;; (core-num 0)) ;; core +;;; ;; (print hed ", " loads ", " proc-num ", " phys-num ", " core-num) +;;; (if (null? tal) ;; have all our data, calculate normalized load and return result +;;; (let* ((act-proc (+ proc-num 1)) +;;; (act-phys (+ phys-num 1)) +;;; (act-core (+ core-num 1)) +;;; (adj-proc-load (/ (car loads) act-proc)) +;;; (adj-core-load (/ (car loads) act-core)) +;;; (result +;;; (append (list (cons 'adj-proc-load adj-proc-load) +;;; (cons 'adj-core-load adj-core-load)) +;;; (list (cons '1m-load (car loads)) +;;; (cons '5m-load (cadr loads)) +;;; (cons '15m-load (caddr loads))) +;;; (list (cons 'proc act-proc) +;;; (cons 'core act-core) +;;; (cons 'phys act-phys))))) +;;; result) +;;; (regex-case +;;; hed +;;; (load-rx ( x l1 l5 l15 ) (loop (car tal)(cdr tal)(map string->number (list l1 l5 l15)) proc-num phys-num core-num)) +;;; (proc-rx ( x p ) (loop (car tal)(cdr tal) loads (max-num p proc-num) phys-num core-num)) +;;; (phys-rx ( x p ) (loop (car tal)(cdr tal) loads proc-num (max-num p phys-num) core-num)) +;;; (core-rx ( x c ) (loop (car tal)(cdr tal) loads proc-num phys-num (max-num c core-num))) +;;; (else +;;; (begin +;;; ;; (print "NO MATCH: " hed) +;;; (loop (car tal)(cdr tal) loads proc-num phys-num core-num)))))))))) +;;; +;;; (define (get-host-stats acfg) +;;; (let ((stats-hash (area-stats acfg))) +;;; ;; use this opportunity to remove references to dbfiles which have not been accessed in a while +;;; (for-each +;;; (lambda (dbname) +;;; (let* ((stats (hash-table-ref stats-hash dbname)) +;;; (last-access (stat-when stats))) +;;; (if (and (> last-access 0) ;; if zero then there has been no access +;;; (> (- (current-seconds) last-access) 10)) ;; not used in ten seconds +;;; (begin +;;; (print "Removing " dbname " from stats list") +;;; (hash-table-delete! stats-hash dbname) ;; remove from stats hash +;;; (stat-dbs-set! stats (hash-table-keys stats)))))) +;;; (hash-table-keys stats-hash)) +;;; +;;; `(,(hash-table->alist (area-dbs acfg)) ;; dbname => randnum +;;; ,(map (lambda (dbname) ;; dbname is the db name +;;; (cons dbname (stat-when (hash-table-ref stats-hash dbname)))) +;;; (hash-table-keys stats-hash)) +;;; (cpuload . ,(get-normalized-cpu-load))))) +;;; #;(stats . ,(map (lambda (k) ;; create an alist from the stats data +;;; (cons k (stat->alist (hash-table-ref (area-stats acfg) k)))) +;;; (hash-table-keys (area-stats acfg)))) +;;; +;;; #;(trace +;;; ;; assv +;;; ;; cdr +;;; ;; caar +;;; ;; ;; cdr +;;; ;; call +;;; ;; finalize-all-db-handles +;;; ;; get-all-server-pkts +;;; ;; get-normalized-cpu-load +;;; ;; get-normalized-cpu-load-raw +;;; ;; launch +;;; ;; nmsg-send +;;; ;; process-db-queries +;;; ;; receive-message +;;; ;; std-peer-handler +;;; ;; update-known-servers +;;; ;; work-queue-processor +;;; ) +;;; +;;; ;;====================================================================== +;;; ;; netutil +;;; ;; move this back to ulex-netutil.scm someday? +;;; ;;====================================================================== +;;; +;;; ;; #include +;;; ;; #include +;;; ;; #include +;;; ;; #include +;;; +;;; (foreign-declare "#include \"sys/types.h\"") +;;; (foreign-declare "#include \"sys/socket.h\"") +;;; (foreign-declare "#include \"ifaddrs.h\"") +;;; (foreign-declare "#include \"arpa/inet.h\"") +;;; +;;; ;; get IP addresses from ALL interfaces +;;; (define get-all-ips +;;; (foreign-safe-lambda* scheme-object () +;;; " +;;; +;;; // from https://stackoverflow.com/questions/17909401/linux-c-get-default-interfaces-ip-address : +;;; +;;; +;;; C_word lst = C_SCHEME_END_OF_LIST, len, str, *a; +;;; // struct ifaddrs *ifa, *i; +;;; // struct sockaddr *sa; +;;; +;;; struct ifaddrs * ifAddrStruct = NULL; +;;; struct ifaddrs * ifa = NULL; +;;; void * tmpAddrPtr = NULL; +;;; +;;; if ( getifaddrs(&ifAddrStruct) != 0) +;;; C_return(C_SCHEME_FALSE); +;;; +;;; // for (i = ifa; i != NULL; i = i->ifa_next) { +;;; for (ifa = ifAddrStruct; ifa != NULL; ifa = ifa->ifa_next) { +;;; if (ifa->ifa_addr->sa_family==AF_INET) { // Check it is +;;; // a valid IPv4 address +;;; tmpAddrPtr = &((struct sockaddr_in *)ifa->ifa_addr)->sin_addr; +;;; char addressBuffer[INET_ADDRSTRLEN]; +;;; inet_ntop(AF_INET, tmpAddrPtr, addressBuffer, INET_ADDRSTRLEN); +;;; // printf(\"%s IP Address %s\\n\", ifa->ifa_name, addressBuffer); +;;; len = strlen(addressBuffer); +;;; a = C_alloc(C_SIZEOF_PAIR + C_SIZEOF_STRING(len)); +;;; str = C_string(&a, len, addressBuffer); +;;; lst = C_a_pair(&a, str, lst); +;;; } +;;; +;;; // else if (ifa->ifa_addr->sa_family==AF_INET6) { // Check it is +;;; // // a valid IPv6 address +;;; // tmpAddrPtr = &((struct sockaddr_in6 *)ifa->ifa_addr)->sin6_addr; +;;; // char addressBuffer[INET6_ADDRSTRLEN]; +;;; // inet_ntop(AF_INET6, tmpAddrPtr, addressBuffer, INET6_ADDRSTRLEN); +;;; //// printf(\"%s IP Address %s\\n\", ifa->ifa_name, addressBuffer); +;;; // len = strlen(addressBuffer); +;;; // a = C_alloc(C_SIZEOF_PAIR + C_SIZEOF_STRING(len)); +;;; // str = C_string(&a, len, addressBuffer); +;;; // lst = C_a_pair(&a, str, lst); +;;; // } +;;; +;;; // else { +;;; // printf(\" not an IPv4 address\\n\"); +;;; // } +;;; +;;; } +;;; +;;; freeifaddrs(ifa); +;;; C_return(lst); +;;; +;;; ")) +;;; +;;; ;; Change this to bias for addresses with a reasonable broadcast value? +;;; ;; +;;; (define (ip-pref-less? a b) +;;; (let* ((rate (lambda (ipstr) +;;; (regex-case ipstr +;;; ( "^127\\." _ 0 ) +;;; ( "^(10\\.0|192\\.168\\.)\\..*" _ 1 ) +;;; ( else 2 ) )))) +;;; (< (rate a) (rate b)))) +;;; +;;; +;;; (define (get-my-best-address) +;;; (let ((all-my-addresses (get-all-ips)) +;;; ;;(all-my-addresses-old (vector->list (hostinfo-addresses (hostname->hostinfo (get-host-name))))) +;;; ) +;;; (cond +;;; ((null? all-my-addresses) +;;; (get-host-name)) ;; no interfaces? +;;; ((eq? (length all-my-addresses) 1) +;;; (car all-my-addresses)) ;; only one to choose from, just go with it +;;; +;;; (else +;;; (car (sort all-my-addresses ip-pref-less?))) +;;; ;; (else +;;; ;; (ip->string (car (filter (lambda (x) ;; take any but 127. +;;; ;; (not (eq? (u8vector-ref x 0) 127))) +;;; ;; all-my-addresses)))) +;;; +;;; ))) +;;; +;;; (define (get-all-ips-sorted) +;;; (sort (get-all-ips) ip-pref-less?)) +;;; +;;; + Index: utils/Makefile.git.installall ================================================================== --- utils/Makefile.git.installall +++ utils/Makefile.git.installall @@ -1,14 +1,22 @@ # Copyright 2013-2015 Matthew Welland. +# +# This file is part of Megatest. +# +# Megatest is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. # -# This program is made available under the GNU GPL version 2.0 or -# greater. See the accompanying file COPYING for details. +# Megatest is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. # -# This program is distributed WITHOUT ANY WARRANTY; without even the -# implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR -# PURPOSE. +# You should have received a copy of the GNU General Public License +# along with Megatest. If not, see . help : @echo You may need to do the following setup first: @echo @echo sudo apt-get install libreadline-dev @@ -47,11 +55,11 @@ PROXY= # http://code.call-cc.org/dev-snapshots/2015/06/07/chicken-4.10.0rc1.tar.gz # http://code.call-cc.org/releases/4.10.0/chicken-4.10.0.tar.gz # Select version of chicken, sqlite3 etc -CHICKEN_VERSION=4.10.1 +CHICKEN_VERSION=4.12.0rc2 SQLITE3_VERSION=3090200 # http://www.sqlite.org/2014/sqlite-autoconf-3080500.tar.gz # http://www.sqlite.org/2015/sqlite-autoconf-3081101.tar.gz # Override IUPBRANCH to use other than trunk IUPBRANCH=trunk @@ -174,10 +182,13 @@ cd chicken-core; pwd cd chicken-core; fossil open ../chicken-scheme.fossil cd chicken-core; fossil up 337f5be # wget http://code.call-cc.org/dev-snapshots/2015/08/29/chicken-4.10.1.tar.gz +chicken-4.12.0rc2.tar.gz : + wget https://code.call-cc.org/dev-snapshots/2017/02/06/chicken-4.12.0rc2.tar.gz + # git clone git://code.call-cc.org/chicken-core # git clone http://code.call-cc.org/git/chicken-core.git $(PRODCHICKEN)/bin/chicken : wget http://code.call-cc.org/dev-snapshots/2015/08/29/chicken-4.10.1.tar.gz @@ -211,23 +222,23 @@ #====================================================================== # https://github.com/nanomsg/nanomsg/releases/download/0.6-beta/nanomsg-0.6-beta.tar.gz # https://github.com/nanomsg/nanomsg/releases/download/0.8-beta/nanomsg-0.8-beta.tar.gz -nanomsg-0.6-beta.tar.gz : - wget http://download.nanomsg.org/nanomsg-0.6-beta.tar.gz - -nanomsg-0.6-beta/COPYING : nanomsg-0.6-beta.tar.gz - tar xf nanomsg-0.6-beta.tar.gz - -$(PREFIX)/bin/nanocat : nanomsg-0.6-beta/COPYING - cd nanomsg-0.6-beta;./configure --prefix=$(PREFIX);make;make install - -$(PREFIX)/lib/nanomsg.so : $(PREFIX)/bin/nanocat - CSC_OPTIONS="-I$(PREFIX)/include -L$(PREFIX)/lib" $(CHICKEN_INSTALL) $(PROX) nanomsg - -# LD_LIBRARY_PATH=/mfs/pkgs/chicken/4.10.0-amd64/lib CSC_OPTIONS="-I/mfs/pkgs/chicken/4.10.0-amd64/include -L/mfs/pkgs/chicken/4.10.0-amd64/lib -C \"-fPIC\"" /mfs/pkgs/chicken/4.10.0-amd64/bin/chicken-install -D no-library-checks nanomsg +# nanomsg-0.6-beta.tar.gz : +# wget http://download.nanomsg.org/nanomsg-0.6-beta.tar.gz + +# nanomsg-0.6-beta/COPYING : nanomsg-0.6-beta.tar.gz +# tar xf nanomsg-0.6-beta.tar.gz + +# $(PREFIX)/bin/nanocat : nanomsg-0.6-beta/COPYING +# cd nanomsg-0.6-beta;./configure --prefix=$(PREFIX);make;make install + +# $(PREFIX)/lib/nanomsg.so : $(PREFIX)/bin/nanocat +# CSC_OPTIONS="-I$(PREFIX)/include -L$(PREFIX)/lib" $(CHICKEN_INSTALL) $(PROX) nanomsg + +# # LD_LIBRARY_PATH=/mfs/pkgs/chicken/4.10.0-amd64/lib CSC_OPTIONS="-I/mfs/pkgs/chicken/4.10.0-amd64/include -L/mfs/pkgs/chicken/4.10.0-amd64/lib -C \"-fPIC\"" /mfs/pkgs/chicken/4.10.0-amd64/bin/chicken-install -D no-library-checks nanomsg #====================================================================== # M A T T S U T I L S #====================================================================== Index: utils/Makefile.installall ================================================================== --- utils/Makefile.installall +++ utils/Makefile.installall @@ -1,14 +1,22 @@ # Copyright 2013-2015 Matthew Welland. # -# This program is made available under the GNU GPL version 2.0 or -# greater. See the accompanying file COPYING for details. +# This file is part of Megatest. +# +# Megatest is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# Megatest is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. # -# This program is distributed WITHOUT ANY WARRANTY; without even the -# implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR -# PURPOSE. +# You should have received a copy of the GNU General Public License +# along with Megatest. If not, see . help : @echo You may need to do the following setup first: @echo @echo sudo apt-get install libreadline-dev @@ -45,11 +53,11 @@ # http://code.call-cc.org/dev-snapshots/2015/06/07/chicken-4.10.0rc1.tar.gz # http://code.call-cc.org/releases/4.10.0/chicken-4.10.0.tar.gz # Select version of chicken, sqlite3 etc # CHICKEN_VERSION=4.10.0 -CHICKEN_VERSION=4.11.0rc2 +CHICKEN_VERSION=4.11.0 SQLITE3_VERSION=3090200 # http://www.sqlite.org/2014/sqlite-autoconf-3080500.tar.gz # http://www.sqlite.org/2015/sqlite-autoconf-3081101.tar.gz # Override IUPBRANCH to use other than trunk IUPBRANCH=trunk @@ -56,11 +64,11 @@ IUPCONFIG=ubuntu-15.04.inc # iup-3.15 # Eggs to install (straightforward ones) EGGS=matchable readline apropos base64 regex-literals format regex-case test coops trace csv \ - dot-locking posix-utils posix-extras directory-utils hostinfo tcp-server rpc csv-xml fmt \ + dot-locking posix-utils posix-extras hostinfo tcp-server rpc csv-xml fmt \ json md5 awful http-client spiffy uri-common intarweb spiffy-request-vars pathname-expand \ spiffy-directory-listing ssax sxml-serializer sxml-modifications sql-de-lite \ srfi-19 refdb ini-file sparse-vectors z3 call-with-environment-variables hahn linenoise \ crypt parley @@ -97,11 +105,11 @@ else ARCHSIZE=64_ endif CSCLIBS=$(shell echo $(LD_LIBRARY_PATH) | sed 's/:/ -L/g') -CSC_OPTIONS="-I$(PREFIX)/include -L$(CSCLIBS) -C \"-fPIC\"" +CSC_OPTIONS="-I$(PREFIX)/include -L$(CSCLIBS) -C -fPIC" # CSC_OPTIONS=-I $(PREFIX)/include -L $(CSCLIBS) nogui : base mutils #all : nogui libiup $(PREFIX)/lib/sqlite3.so @@ -137,11 +145,12 @@ mkdir -p eggflags touch $(EGGFLAGS) # some setup stuff # -$(PREFIX)/setup-chicken4x.sh : $(EGGFLAGS) +#$(PREFIX)/setup-chicken4x.sh : $(EGGFLAGS) +$(PREFIX)/setup-chicken4x.sh : mkdir -p $(PREFIX) (echo 'export PATH=$(PREFIX)/bin:$$PATH' > $(PREFIX)/setup-chicken4x.sh) (echo "export LD_LIBRARY_PATH=$(LD_LIBRARY_PATH)" >> $(PREFIX)/setup-chicken4x.sh) $(PREFIX)/setup-chicken4x.csh : $(EGGFLAGS) @@ -149,35 +158,26 @@ (echo "setenv PATH $(PREFIX):'$$'PATH" > $(PREFIX)/setup-chicken4x.csh) (echo "setenv LD_LIBRARY_PATH $(LD_LIBRARY_PATH)" >> $(PREFIX)/setup-chicken4x.csh) # NOTE: the touch chicken-core/chicken.scm compensates for the time stamp from the tar file chicken-core/chicken.scm : chicken-$(CHICKEN_VERSION).tar.gz - tar xf chicken-$(CHICKEN_VERSION).tar.gz + tar xzf chicken-$(CHICKEN_VERSION).tar.gz ln -sf chicken-$(CHICKEN_VERSION) chicken-core if [[ -e chicken-core/chicken.scm ]];then touch chicken-core/chicken.scm;fi -chicken-4.9.0rc1.tar.gz : - wget http://code.call-cc.org/dev-snapshots/2014/04/17/chicken-4.9.0rc1.tar.gz - -chicken-4.9.0.1.tar.gz : - wget http://code.call-cc.org/releases/4.9.0/chicken-4.9.0.1.tar.gz - -chicken-4.10.0rc1.tar.gz : - wget http://code.call-cc.org/dev-snapshots/2015/06/07/chicken-4.10.0rc1.tar.gz - -chicken-4.10.0.tar.gz : - wget http://code.call-cc.org/releases/4.10.0/chicken-4.10.0.tar.gz - -chicken-4.11.0rc2.tar.gz : - wget http://code.call-cc.org/dev-snapshots/2016/04/28/chicken-4.11.0rc2.tar.gz +chicken-4.11.0.tar.gz : + wget http://code.call-cc.org/releases/4.11.0/chicken-4.11.0.tar.gz # git clone git://code.call-cc.org/chicken-core # git clone http://code.call-cc.org/git/chicken-core.git $(CHICKEN_INSTALL) : chicken-core/chicken.scm $(PREFIX)/setup-chicken4x.sh $(PREFIX)/setup-chicken4x.csh - cd chicken-core;make PLATFORM=linux PREFIX=$(PREFIX) - cd chicken-core;make PLATFORM=linux PREFIX=$(PREFIX) install + pwd; env; which make + cd chicken-core; make PLATFORM=linux PREFIX=$(PREFIX) + cd chicken-core; make PLATFORM=linux PREFIX=$(PREFIX) install + #cd chicken-core;env -i PATH=${PATH} LD_LIBRARY_PATH=${LD_LIBRARY_PATH} make PLATFORM=linux PREFIX=$(PREFIX) + #cd chicken-core;env -i PATH=${PATH} LD_LIBRARY_PATH=${LD_LIBRARY_PATH} make PLATFORM=linux PREFIX=$(PREFIX) install #====================================================================== # S Q L I T E 3 #====================================================================== # https://www.sqlite.org/2015/sqlite-autoconf-3090200.tar.gz @@ -195,26 +195,26 @@ #====================================================================== # N A N O M S G #====================================================================== -# https://github.com/nanomsg/nanomsg/releases/download/0.6-beta/nanomsg-0.6-beta.tar.gz -# https://github.com/nanomsg/nanomsg/releases/download/0.8-beta/nanomsg-0.8-beta.tar.gz - -nanomsg-0.6-beta.tar.gz : - wget http://download.nanomsg.org/nanomsg-0.6-beta.tar.gz - -nanomsg-0.6-beta/COPYING : nanomsg-0.6-beta.tar.gz - tar xf nanomsg-0.6-beta.tar.gz - -$(PREFIX)/bin/nanocat : nanomsg-0.6-beta/COPYING - cd nanomsg-0.6-beta;./configure --prefix=$(PREFIX);make;make install - -$(PREFIX)/lib/nanomsg.so : $(PREFIX)/bin/nanocat - CSC_OPTIONS="-I$(PREFIX)/include -L$(PREFIX)/lib" $(CHICKEN_INSTALL) $(PROX) nanomsg - -# LD_LIBRARY_PATH=/mfs/pkgs/chicken/4.10.0-amd64/lib CSC_OPTIONS="-I/mfs/pkgs/chicken/4.10.0-amd64/include -L/mfs/pkgs/chicken/4.10.0-amd64/lib -C \"-fPIC\"" /mfs/pkgs/chicken/4.10.0-amd64/bin/chicken-install -D no-library-checks nanomsg +# # https://github.com/nanomsg/nanomsg/releases/download/0.6-beta/nanomsg-0.6-beta.tar.gz +# # https://github.com/nanomsg/nanomsg/releases/download/0.8-beta/nanomsg-0.8-beta.tar.gz + +# nanomsg-0.6-beta.tar.gz : +# wget http://download.nanomsg.org/nanomsg-0.6-beta.tar.gz + +# nanomsg-0.6-beta/COPYING : nanomsg-0.6-beta.tar.gz +# tar xf nanomsg-0.6-beta.tar.gz + +# $(PREFIX)/bin/nanocat : nanomsg-0.6-beta/COPYING +# cd nanomsg-0.6-beta;./configure --prefix=$(PREFIX);make;make install + +# $(PREFIX)/lib/nanomsg.so : $(PREFIX)/bin/nanocat +# CSC_OPTIONS="-I$(PREFIX)/include -L$(PREFIX)/lib" $(CHICKEN_INSTALL) $(PROX) nanomsg + +# # LD_LIBRARY_PATH=/mfs/pkgs/chicken/4.10.0-amd64/lib CSC_OPTIONS="-I/mfs/pkgs/chicken/4.10.0-amd64/include -L/mfs/pkgs/chicken/4.10.0-amd64/lib -C \"-fPIC\"" /mfs/pkgs/chicken/4.10.0-amd64/bin/chicken-install -D no-library-checks nanomsg #====================================================================== # M A T T S U T I L S #====================================================================== @@ -235,11 +235,12 @@ $(PREFIX)/lib/chicken/8/margs.so : opensrc/margs/margs.scm cd opensrc/margs;chicken-install opensrc/histstore/hs : opensrc/histstore/histstore.scm chkn eggs $(CHICKEN_EGG_DIR)/sqlite3.so - cd opensrc/histstore;$(PREFIX)/bin/csc histstore.scm -o hs + env | grep CSC + cd opensrc/histstore; $(PREFIX)/bin/csc histstore.scm -o hs $(PREFIX)/bin/hs : opensrc/histstore/hs cp -f opensrc/histstore/hs $(PREFIX)/bin/hs # stml @@ -254,11 +255,11 @@ stml/requirements.scm : stml/requirements.scm.template cp stml/install.cfg.template stml/install.cfg cp stml/requirements.scm.template stml/requirements.scm $(PREFIX)/lib/chicken/8/stml.so : stml/requirements.scm - cd stml;make + cd stml; make #====================================================================== # F F C A L L (Used by IUP) #====================================================================== @@ -280,34 +281,47 @@ iuplib.fossil : fossil clone http://www.kiatoa.com/fossils/iuplib iuplib.fossil cd-5.9_Linux26g4_64_lib.tar.gz : - wget -c http://sourceforge.net/projects/canvasdraw/files/5.9/Linux%20Libraries/cd-5.9_Linux26g4_64_lib.tar.gz/download + wget --no-check-certificate -c http://sourceforge.net/projects/canvasdraw/files/5.9/Linux%20Libraries/cd-5.9_Linux26g4_64_lib.tar.gz/download mv download cd-5.9_Linux26g4_64_lib.tar.gz +cd-5.10_Linux26g4_64_lib.tar.gz : + cp /p/fdk/gwa/jmoon18/cd-5.10_Linux26g4_64_lib.tar.gz cd-5.10_Linux26g4_64_lib.tar.gz + iup-3.17_Linux26g4_64_lib.tar.gz : - wget -c http://sourceforge.net/projects/iup/files/3.17/Linux%20Libraries/iup-3.17_Linux26g4_64_lib.tar.gz/download - mv download iup-3.17_Linux26g4_64_lib.tar.gz + cp /p/fdk/gwa/jmoon18/iup-3.17_Linux26g4_64_lib.tar.gz iup-3.17_Linux26g4_64_lib.tar.gz +# wget --no-check-certificate -c http://sourceforge.net/projects/iup/files/3.17/Linux%20Libraries/iup-3.17_Linux26g4_64_lib.tar.gz/download +# mv download iup-3.17_Linux26g4_64_lib.tar.gz + +iup-3.19.1_Linux26g4_64_lib.tar.gz : + cp /p/fdk/gwa/jmoon18/iup-3.19.1_Linux26g4_64_lib.tar.gz iup-3.19.1_Linux26g4_64_lib.tar.gz im-3.10_Linux26g4_64_lib.tar.gz : - wget -c http://sourceforge.net/projects/imtoolkit/files/3.10/Linux%20Libraries/im-3.10_Linux26g4_64_lib.tar.gz/download + wget --no-check-certificate -c http://sourceforge.net/projects/imtoolkit/files/3.10/Linux%20Libraries/im-3.10_Linux26g4_64_lib.tar.gz/download mv download im-3.10_Linux26g4_64_lib.tar.gz +im-3.11_Linux26g4_64_lib.tar.gz : + cp /p/fdk/gwa/jmoon18/im-3.11_Linux26g4_64_lib.tar.gz im-3.11_Linux26g4_64_lib.tar.gz + lua-5.3.2_Linux26g4_64_lib.tar.gz : - wget -c http://sourceforge.net/projects/luabinaries/files/5.3.2/Linux%20Libraries/lua-5.3.2_Linux26g4_64_lib.tar.gz/download + wget --no-check-certificate -c http://sourceforge.net/projects/luabinaries/files/5.3.2/Linux%20Libraries/lua-5.3.2_Linux26g4_64_lib.tar.gz/download mv download lua-5.3.2_Linux26g4_64_lib.tar.gz +lua-5.3.3_Linux26g4_64_lib.tar.gz : + cp /p/fdk/gwa/jmoon18/lua-5.3.3_Linux26g4_64_lib.tar.gz lua-5.3.3_Linux26g4_64_lib.tar.gz + iup/installall.sh : $(PREFIX)/lib/libiup.so \ - cd-5.9_Linux26g4_64_lib.tar.gz \ + cd-5.10_Linux26g4_64_lib.tar.gz \ iup-3.17_Linux26g4_64_lib.tar.gz \ - im-3.10_Linux26g4_64_lib.tar.gz \ - lua-5.3.2_Linux26g4_64_lib.tar.gz # iuplib.fossil + im-3.11_Linux26g4_64_lib.tar.gz \ + lua-5.3.3_Linux26g4_64_lib.tar.gz # iuplib.fossil mkdir -p iup pwd - tar -xzvf cd-5.9_Linux26g4_64_lib.tar.gz -C iup/ - tar -xzvf im-3.10_Linux26g4_64_lib.tar.gz -C iup/ + tar -xzvf cd-5.10_Linux26g4_64_lib.tar.gz -C iup/ + tar -xzvf im-3.11_Linux26g4_64_lib.tar.gz -C iup/ tar -xzvf iup-3.17_Linux26g4_64_lib.tar.gz -C iup/ mkdir -p $(PREFIX)/include/ $(PREFIX)/lib/ cp iup/include/* $(PREFIX)/include/ cp iup/*.so $(PREFIX)/lib/ cp iup/*.a $(PREFIX)/lib/ @@ -331,6 +345,6 @@ $(CHICKEN_EGG_DIR)/canvas-draw.so : $(PREFIX)/lib/libiup.so $(PREFIX)/lib/libavcall.a CSC_OPTIONS=$(CSC_OPTIONS) $(CHICKEN_INSTALL) $(PROX) -D no-library-checks canvas-draw clean : - rm -rf chicken-4.8.0 eggflags ffcall sqlite-autoconf-$(SQLITE3_VERSION) + rm -rf chicken-4.11.0 eggflags ffcall sqlite-autoconf-$(SQLITE3_VERSION) Index: utils/Makefile.latest.installall ================================================================== --- utils/Makefile.latest.installall +++ utils/Makefile.latest.installall @@ -1,14 +1,23 @@ # Copyright 2013-2015 Matthew Welland. # -# This program is made available under the GNU GPL version 2.0 or -# greater. See the accompanying file COPYING for details. +# This file is part of Megatest. +# +# Megatest is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# Megatest is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. # -# This program is distributed WITHOUT ANY WARRANTY; without even the -# implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR -# PURPOSE. +# You should have received a copy of the GNU General Public License +# along with Megatest. If not, see . + help : @echo You may need to do the following setup first: @echo @echo sudo apt-get install libreadline-dev @@ -195,26 +204,26 @@ #====================================================================== # N A N O M S G #====================================================================== -# https://github.com/nanomsg/nanomsg/releases/download/0.6-beta/nanomsg-0.6-beta.tar.gz -# https://github.com/nanomsg/nanomsg/releases/download/0.8-beta/nanomsg-0.8-beta.tar.gz - -nanomsg-0.6-beta.tar.gz : - wget http://download.nanomsg.org/nanomsg-0.6-beta.tar.gz - -nanomsg-0.6-beta/COPYING : nanomsg-0.6-beta.tar.gz - tar xf nanomsg-0.6-beta.tar.gz - -$(PREFIX)/bin/nanocat : nanomsg-0.6-beta/COPYING - cd nanomsg-0.6-beta;./configure --prefix=$(PREFIX);make;make install - -$(PREFIX)/lib/nanomsg.so : $(PREFIX)/bin/nanocat - CSC_OPTIONS="-I$(PREFIX)/include -L$(PREFIX)/lib" $(CHICKEN_INSTALL) $(PROX) nanomsg - -# LD_LIBRARY_PATH=/mfs/pkgs/chicken/4.10.0-amd64/lib CSC_OPTIONS="-I/mfs/pkgs/chicken/4.10.0-amd64/include -L/mfs/pkgs/chicken/4.10.0-amd64/lib -C \"-fPIC\"" /mfs/pkgs/chicken/4.10.0-amd64/bin/chicken-install -D no-library-checks nanomsg +# # https://github.com/nanomsg/nanomsg/releases/download/0.6-beta/nanomsg-0.6-beta.tar.gz +# # https://github.com/nanomsg/nanomsg/releases/download/0.8-beta/nanomsg-0.8-beta.tar.gz + +# nanomsg-0.6-beta.tar.gz : +# wget http://download.nanomsg.org/nanomsg-0.6-beta.tar.gz + +# nanomsg-0.6-beta/COPYING : nanomsg-0.6-beta.tar.gz +# tar xf nanomsg-0.6-beta.tar.gz + +# $(PREFIX)/bin/nanocat : nanomsg-0.6-beta/COPYING +# cd nanomsg-0.6-beta;./configure --prefix=$(PREFIX);make;make install + +# $(PREFIX)/lib/nanomsg.so : $(PREFIX)/bin/nanocat +# CSC_OPTIONS="-I$(PREFIX)/include -L$(PREFIX)/lib" $(CHICKEN_INSTALL) $(PROX) nanomsg + +# # LD_LIBRARY_PATH=/mfs/pkgs/chicken/4.10.0-amd64/lib CSC_OPTIONS="-I/mfs/pkgs/chicken/4.10.0-amd64/include -L/mfs/pkgs/chicken/4.10.0-amd64/lib -C \"-fPIC\"" /mfs/pkgs/chicken/4.10.0-amd64/bin/chicken-install -D no-library-checks nanomsg #====================================================================== # M A T T S U T I L S #====================================================================== ADDED utils/Makefile.whodunit Index: utils/Makefile.whodunit ================================================================== --- /dev/null +++ utils/Makefile.whodunit @@ -0,0 +1,9 @@ +.DEFAULT : all + +all : whodunit + +clean : + rm whodunit + +whodunit : whodunit.scm + csc -static -L -static -L -lm -L -ldl -L -lpthread -L -lssl -L -lcrypto -L -lz whodunit.scm -o whodunit ADDED utils/checkPreReqs Index: utils/checkPreReqs ================================================================== --- /dev/null +++ utils/checkPreReqs @@ -0,0 +1,48 @@ +#!/bin/bash + +# Copyright 2006-2017, Matthew Welland. +# +# This file is part of Megatest. +# +# Megatest is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# Megatest is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with Megatest. If not, see . + +SYSTEM_TYPE=$(lsb_release -irs |tr ' ' '_' |tr '\n' '-')$(uname -i) +file=`/bin/mktemp` +case $SYSTEM_TYPE in +Ubuntu-17.04-x86_64-std) + apt list --installed | cut -d/ -f 1 > $file + ;; +Ubuntu-16.04-x86_64) + apt list --installed | cut -d/ -f 1 > $file + ;; +Ubuntu-16.04-i686) + apt list --installed | cut -d/ -f 1 > $file + ;; +SUSE_LINUX_11-x86_64) + rpm -qa > $file + ;; +CentOS_5.11-x86_64-std) + rpm -qa > $file + ;; +esac + + + +for package in libmysqlclient-dev libsqlite3-dev sqlite3 postgresql libreadline-dev libwebkitgtk-dev libpangox-1.0-0 zlib1g-dev libfreetype6 cmake libssl-dev uuid-dev libmotif3 mysql-client; do + grep --silent $package $file + if [ "$?" != "0" ]; then + echo "sudo apt install $package" + fi +done +rm $file Index: utils/cleanup-links-dir.sh ================================================================== --- utils/cleanup-links-dir.sh +++ utils/cleanup-links-dir.sh @@ -1,7 +1,24 @@ #!/usr/bin/env bash +# Copyright 2006-2017, Matthew Welland. +# +# This file is part of Megatest. +# +# Megatest is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# Megatest is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with Megatest. If not, see . + export LINKSDIR=$1 export RUNSDIR=$2 if [ "x$LINKSDIR" == "x" ];then echo Usage: cleanup-links-dir /links/dir/path /runs/dir/path ADDED utils/cleanup-pkts.sh Index: utils/cleanup-pkts.sh ================================================================== --- /dev/null +++ utils/cleanup-pkts.sh @@ -0,0 +1,29 @@ +#!/bin/bash + +# Copyright 2006-2017, Matthew Welland. +# +# This file is part of Megatest. +# +# Megatest is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# Megatest is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with Megatest. If not, see . + +pushd $1 + +for x in *.pkt;do + if grep 'T configf' $x > /dev/null;then + rm $x + else + echo skip $x + fi +done + Index: utils/deploy.sh ================================================================== --- utils/deploy.sh +++ utils/deploy.sh @@ -1,7 +1,24 @@ #!/bin/bash +# Copyright 2006-2017, Matthew Welland. +# +# This file is part of Megatest. +# +# Megatest is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# Megatest is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with Megatest. If not, see . + set -x if [[ $DEPLOYTARG == "" ]] ; then echo Installing into deploytarg export DEPLOYTARG=$PWD/deploytarg ADDED utils/editwiki Index: utils/editwiki ================================================================== --- /dev/null +++ utils/editwiki @@ -0,0 +1,73 @@ +#!/bin/bash + +# Copyright 2006-2017, Matthew Welland. +# +# This file is part of Megatest. +# +# Megatest is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# Megatest is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with Megatest. If not, see . + +wikiname=$1 +FOSSILBIN=fossil + +if [ x"$wikiname" == "x" ];then + echo "Usage: viwiki wikipagename" + exit +fi + +$FOSSILBIN sync + +# wikitmpfile=`mktemp /tmp/${USER}_wikiedit.XXXXXXX` +wikitmpfile=${wikiname}.in + +if ! $FOSSILBIN wiki export "$wikiname" 2> /dev/null 1> $wikitmpfile ;then + cat /dev/null > $wikitmpfile + wikipagestate='new' +else + wikipagestate='existing' +fi + +# make a backup copy of the extracted file to diff detect if changed +cp $wikitmpfile ${wikitmpfile}.orig + +if [[ x"$EDITOR" == "x" ]];then # || [[ x"$VISUAL" == "x" ]];then + EDITOR="gvim -f" +fi + +echo $EDITOR | grep -q -e gvim +isGvim=$? + +echo $EDITOR | grep -q -e 'gvim.*-f' +hasF=$? + +if [[ $isGvim == 0 && $hasF != 0 ]]; then + EDITOR="$EDITOR -f" +fi + +$EDITOR $wikitmpfile + +if ! diff -q $wikitmpfile ${wikitmpfile}.orig;then + echo "Saving changes to $wikitmpfile to wiki" + if [ $wikipagestate == 'new' ];then + $FOSSILBIN wiki create "$wikiname" $wikitmpfile + else + $FOSSILBIN wiki commit "$wikiname" $wikitmpfile + fi +else + echo "Not saving, no changes to $wikitmpfile." +fi + +$FOSSILBIN sync + +# NOTE// We *keep* the wikitmpfile but remove the orig copy +rm -f ${wikitmpfile}.orig Index: utils/example-launch-dispatcher.scm ================================================================== --- utils/example-launch-dispatcher.scm +++ utils/example-launch-dispatcher.scm @@ -1,5 +1,22 @@ +;; Copyright 2006-2017, Matthew Welland. +;; +;; This file is part of Megatest. +;; +;; Megatest is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. +;; +;; Megatest is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with Megatest. If not, see . +;; (let ((target (assoc ;; Put the variable name here, note: only *one* ' ;; 'TARGET_OS 'MANYITEMS ADDED utils/find-unused-globals.sh Index: utils/find-unused-globals.sh ================================================================== --- /dev/null +++ utils/find-unused-globals.sh @@ -0,0 +1,46 @@ +#!/bin/bash + +# Copyright 2006-2017, Matthew Welland. +# +# This file is part of Megatest. +# +# Megatest is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# Megatest is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with Megatest. If not, see . + +echo "Finding unused globals:" + +for var in $(egrep '^\s*\(define\s+\*' *.scm|awk '{print $2}'|sort -u);do + if ! $(egrep -v '^\s*\(define' *scm| grep "$var" > /dev/null);then + echo "$var not used"; + fi; +done + +echo +echo "Finding globals without proper definition in common.scm:" + +for var in $(egrep -v '^\s*\(define' *.scm|\ + grep -P -v '^\s*;'|\ + grep -P '\*[a-zA-Z]+\S+\*'|\ + tr '*' '/' |\ + perl -p -e 's%.*(\/\S+\/).*%$1%'|\ + egrep '\/[a-zA-Z]+\S+\/'|\ + sort -u);do + newvar=$(echo $var | tr '/' '*') + # echo "VAR is $var, newvar is $newvar" + if ! $(grep -P '^\s*\(define\s+' common.scm|\ + grep -P -v '^\s*;'|\ + grep "$newvar" > /dev/null);then + echo "$newvar not defined in common.scm" + fi +done + ADDED utils/fslrept.scm Index: utils/fslrept.scm ================================================================== --- /dev/null +++ utils/fslrept.scm @@ -0,0 +1,108 @@ +;; Copyright 2006-2017, Matthew Welland. +;; +;; This file is part of Megatest. +;; +;; Megatest is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. +;; +;; Megatest is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with Megatest. If not, see . +;; + +(use json fmt posix) + +;; abstract out the alist-ref a bit and re-order the params +;; +(define-inline (aref dat key) + (alist-ref key dat equal?)) + +;; convert silly vectors in json data to nice clean alist +;; +(define (to-alist inlst) + (handle-exceptions + exn + (begin + (print-call-chain) + (print inlst)) + (cond + ((proper-list? inlst) (map to-alist inlst)) + ((or (list? inlst) ;; it is a pair + (pair? inlst)) (cons (car inlst) (to-alist (cdr inlst)))) + ((vector? inlst) (to-alist (vector->list inlst))) + (else inlst)))) + +;; columnar line printer +;; +(define (print-rows inlist) + (define (print-line x) + (cat (car x) + (space-to 10)(pad/left 3 (cadr x)) + (space-to 25)(pad/left 3 (caddr x)) + )) + (fmt #t (pad-char #\ (fmt-join/suffix print-line inlist nl)))) + +;; from the command line pull branch, start-tag, end-tag +;; +(define (extract-history branch start-tag end-tag) + (let* ((data (to-alist ;; get all the data + (with-input-from-pipe + "fossil json timeline checkin -n 0" + json-read))) + (timeline (aref (aref data "payload") "timeline")) ;; extract the timeline alists + (start-flag #f) + (end-flag #f)) + ;; now we have all needed data as a list of alists in time order, extract the + ;; messages for given branch starting at start-tag and ending at end-tag + (reverse ;; return results oldest to newest + (filter + (lambda (x) x) + (map + (lambda (entry) + (let ((tags (aref entry "tags"))) + (if (or (not tags) ;; eh? + (not (list? tags))) + (begin + ;; (with-output-to-port (current-error-port) + ;; (lambda () + ;; (print "ERROR: bad entry. tags: " tags))) + #f) + (let* ((btag (car tags)) ;; first tag is the primary branch + (tags (cdr tags)) ;; remainder are actual tags + (cmt (aref entry "comment")) + (usr (aref entry "user")) + (tms (aref entry "timestamp"))) + ;; (print "btag: " btag " tags: " tags " usr: " usr) + (if (equal? btag branch) ;; we are on the branch + (begin + (if (member start-tag tags)(set! start-flag #t)) + (let ((res (if (and start-flag + (not end-flag)) + `(,usr + ,(time->string (seconds->local-time tms) "WW%U.%w %H:%M") + ,cmt) + #f))) + (if (member end-tag tags)(set! end-flag #t)) + res)) + #f))))) + (reverse timeline)))))) + +(define (process-fossil branch start-tag end-tag) + (print-rows + (extract-history branch start-tag end-tag))) + +;; process command line args and dispatch the call to fossil processing +;; +(if (and (> (length (argv)) 3) + (< (length (argv)) 5)) + (apply process-fossil (cdr (argv))) + (begin ;; no inputs, exit with message + (print "Usage: fslrept branch start-tag end-tag") + )) + ADDED utils/gen-build-info.sh Index: utils/gen-build-info.sh ================================================================== --- /dev/null +++ utils/gen-build-info.sh @@ -0,0 +1,16 @@ +echo "Data gathered on $(date)" +echo +echo "Megatest code node: $(fossil status | grep checkout: | awk '{print $2}')" +echo +echo "Host: $HOSTNAME" +echo +echo "Which csi: $(which csi)" +echo +echo "Version info from csc -version:" +csc -version +echo +echo "Eggs info from chicken-status:" +chicken-status +echo +echo "Host info from lsb_release -a:" +lsb_release -a ADDED utils/homehost_check.sh Index: utils/homehost_check.sh ================================================================== --- /dev/null +++ utils/homehost_check.sh @@ -0,0 +1,34 @@ +#! /bin/bash + +# Copyright 2006-2017, Matthew Welland. +# +# This file is part of Megatest. +# +# Megatest is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# Megatest is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with Megatest. If not, see . + +#exits 1 when current host is not homehost. + +if [[ ! -e .homehost ]]; then + exit 0 +fi + +homehostname=$( host `cat .homehost` | awk '{print $NF}' | sed 's/\.$//' ) +hostname=$( hostname -f ) + +if [[ $homehostname == $hostname ]]; then + exit 0 +fi +echo "ERROR: this host ($homehostname) is not the megatest homehost ($hostname)" +exit 1 + Index: utils/installall.logpro ================================================================== --- utils/installall.logpro +++ utils/installall.logpro @@ -1,8 +1,23 @@ ;; (c) 2006,2007,2008,2009 Matthew Welland matt@kiatoa.com ;; -;; License GPL. +;; Copyright 2006-2017, Matthew Welland. +;; +;; This file is part of Megatest. +;; +;; Megatest is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. +;; +;; Megatest is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with Megatest. If not, see . ;; first ensure your run at least started ;; (trigger "Body" #/^.*$/) ;; anything starts the body Index: utils/installall.sh ================================================================== --- utils/installall.sh +++ utils/installall.sh @@ -1,30 +1,128 @@ #! /usr/bin/env bash +# This file installs prerequisites for megatest (chicken, eggs, etc.) +# Before running this script, set PREFIX environment variable +# to chicken install target area. /opt/chicken is a typical value # set -x # Copyright 2007-2014, Matthew Welland. # -# This program is made available under the GNU GPL version 2.0 or -# greater. See the accompanying file COPYING for details. +# This file is part of Megatest. +# +# Megatest is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# Megatest is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. # -# This program is distributed WITHOUT ANY WARRANTY; without even the -# implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR -# PURPOSE. +# You should have received a copy of the GNU General Public License +# along with Megatest. If not, see . + +# echo OPTION=$OPTION + +# BKM for ubuntu 17.04: +# sudo dpkg -i libpng12-0_1.2.54-1ubuntu1_amd64.deb +# sudo dpkg -i libpng12-0_1.2.54-1ubuntu1_amd64.deb + + +if [[ $OPTION == "" ]]; then + export OPTION=std +fi echo You may need to do the following first: -echo sudo apt-get install libreadline-dev -echo sudo apt-get install libwebkitgtk-dev -echo sudo apt-get install libssl-dev -echo sudo apt-get install libmotif3 -OR- set KTYPE=26g4 -echo KTYPE can be 26, 26g4, or 32 -echo -echo KTYPE=$KTYPE +echo sudo apt install libreadline-dev +echo sudo apt install libwebkitgtk-dev +echo sudo apt install libpangox-1.0-0 zlib1g-dev libfreetype6-dev cmake +echo sudo apt install libssl-dev uuid-dev +echo sudo apt install libmotif3 -OR- set KTYPE=26g4 +echo sudo apt install cmake curl ruby wget +echo +echo Set OPTION to std, currently OPTION=$OPTION +echo +echo Additionally, if you want mysql-client, you will need to make sure +echo mysql_config is in your path +echo for postgres to install dbi libpq-dev +echo echo You are using PREFIX=$PREFIX echo You are using proxy="$proxy" echo echo "Set additional_libpath to help find gtk or other libraries, don't forget a leading :" + +SYSTEM_TYPE=$(lsb_release -irs |tr ' ' '_' |tr '\n' '-')$(uname -i)-$OPTION + +CHICKEN_VERSION=4.10.0 +CHICKEN_BASEVER=4.10.0 + +# Set up variables +# +case $SYSTEM_TYPE in +Ubuntu-17.10-x86_64-std) + KTYPE=32 + CDVER=5.11.1 + IUPVER=3.22 + IMVER=3.12 +# CHICKEN_VERSION=4.12.0 +# CHICKEN_BASEVER=4.12.0 + ;; +Ubuntu-17.04-x86_64-std) + KTYPE=32 + CDVER=5.11.1 + IUPVER=3.22 + IMVER=3.12 +# CHICKEN_VERSION=4.12.0 +# CHICKEN_BASEVER=4.12.0 + ;; +Ubuntu-16.04-x86_64-std) + KTYPE=32 + CDVER=5.11.1 + IUPVER=3.22 + IMVER=3.12 +# CHICKEN_VERSION=4.12.0 +# CHICKEN_BASEVER=4.12.0 + ;; +Ubuntu-16.04-x86_64-new) + KTYPE=32 + CDVER=5.11.1 + IUPVER=3.22 + IMVER=3.12 + CHICKEN_VERSION=4.13.0 + CHICKEN_BASEVER=4.13.0 + ;; +Ubuntu-16.04-i686-std) + KTYPE=32 + CDVER=5.11.1 + IUPVER=3.22 + IMVER=3.12 +# CHICKEN_VERSION=4.12.0 +# CHICKEN_BASEVER=4.12.0 + ;; +SUSE_LINUX_11-x86_64-std) + KTYPE=26g4 + CDVER=5.11.1 + IUPVER=3.22 + IMVER=3.12 + ;; +CentOS_5.11-x86_64-std) + KTYPE=24g3 + CDVER=5.4.1 + IUPVER=3.5 + IMVER=3.6.3 + ;; +esac + +echo SYSTEM_TYPE=$SYSTEM_TYPE +echo KTYPE=$KTYPE +echo CDVER=$CDVER +echo IUPVER=$IUPVER +echo IMVER=$IMVER +echo CHICKEN_VERSION=$CHICKEN_VERSION +echo CHICKEN_BASEVER=$CHICKEN_BASEVER # NOTES: # # Centos with security setup may need to do commands such as following as root: # @@ -50,26 +148,25 @@ if [[ $proxy == "" ]]; then echo 'Please set the environment variable "proxy" to host.com:port (e.g. foo.com:1234) to use a proxy' echo PROX="" else export http_proxy=http://$proxy + export https_proxy=http://$proxy export PROX="-proxy $proxy" fi if [[ $KTYPE == "" ]]; then echo 'Using KTYPE=26' - export KTYPE=26 + export KTYPE=26g4 else echo Using KTYPE=$KTYPE fi # Put all the downloaded tar files in tgz mkdir -p tgz # http://code.call-cc.org/releases/4.8.0/chicken-4.8.0.5.tar.gz -export CHICKEN_VERSION=4.8.0.5 -export CHICKEN_BASEVER=4.8.0 chicken_targz=chicken-${CHICKEN_VERSION}.tar.gz if ! [[ -e tgz/$chicken_targz ]]; then wget http://code.call-cc.org/releases/${CHICKEN_BASEVER}/${chicken_targz} mv $chicken_targz tgz fi @@ -80,167 +177,257 @@ if [[ $PREFIX == "" ]]; then PREFIX=$PWD/inst fi export PATH=$PREFIX/bin:$PATH -export LIBPATH=$PREFIX/lib$ADDITIONAL_LIBPATH +export LIBPATH=$PREFIX/lib:$PREFIX/lib64:$ADDITIONAL_LIBPATH export LD_LIBRARY_PATH=$LIBPATH export CHICKEN_INSTALL=$PREFIX/bin/chicken-install -echo "export PATH=$PREFIX/bin:\$PATH" > setup-chicken4x.sh -echo "export LD_LIBRARY_PATH=$LD_LIBRARY_PATH" >> setup-chicken4x.sh +mkdir -p $PREFIX +echo "export PATH=$PREFIX/bin:\$PATH" > $PREFIX/setup-chicken4x.sh +echo "export LD_LIBRARY_PATH=$LD_LIBRARY_PATH:\$LD_LIBRARY_PATH" >> $PREFIX/setup-chicken4x.sh +echo "export CHICKEN_DOC_PAGER=cat" >> $PREFIX/setup-chicken4x.sh + +echo "setenv PATH $PREFIX/bin:\$PATH" > $PREFIX/setup-chicken4x.csh +echo "setenv LD_LIBRARY_PATH $LD_LIBRARY_PATH:\$LD_LIBRARY_PATH" >> $PREFIX/setup-chicken4x.csh +echo "setenv CHICKEN_DOC_PAGER cat" >> $PREFIX/setup-chicken4x.csh echo PATH=$PATH echo LD_LIBRARY_PATH=$LD_LIBRARY_PATH if ! [[ -e $PREFIX/bin/csi ]]; then - tar xfvz tgz/$chicken_targz + tar xfz tgz/$chicken_targz cd chicken-${CHICKEN_VERSION} # make PLATFORM=linux PREFIX=$PREFIX spotless make PLATFORM=linux PREFIX=$PREFIX make PLATFORM=linux PREFIX=$PREFIX install cd $BUILDHOME fi +cd $BUILDHOME +#if [[ ! -e 1.0.0.tar.gz ]];then +# wget --no-check-certificate https://github.com/nanomsg/nanomsg/archive/1.0.0.tar.gz +# mv 1.0.0 1.0.0.tar.gz +#fi +if ! [[ -e $PREFIX/lib/libnanomsg.so ]]; then + wget --no-check-certificate https://github.com/nanomsg/nanomsg/archive/1.0.0.tar.gz + mv 1.0.0 1.0.0.tar.gz + tar xf 1.0.0.tar.gz + cd nanomsg-1.0.0 + ./configure --prefix=$PREFIX + make + make install + CSC_OPTIONS="-I$PREFIX/include -L$PREFIX/lib" $CHICKEN_INSTALL $PROX nanomsg +fi +cd $BUILDHOME + +export SQLITE3_VERSION=3090200 +if ! [[ -e $PREFIX/bin/sqlite3 ]]; then + echo Install sqlite3 + sqlite3_tgz=sqlite-autoconf-$SQLITE3_VERSION.tar.gz + if ! [[ -e tgz/$sqlite3_tgz ]]; then + wget http://www.sqlite.org/2015/$sqlite3_tgz + mv $sqlite3_tgz tgz + fi + + if ! [[ -e $PREFIX/bin/sqlite3 ]] ; then + if [[ -e tgz/sqlite-autoconf-$SQLITE3_VERSION.tar.gz ]]; then + tar xfz tgz/sqlite-autoconf-$SQLITE3_VERSION.tar.gz + (cd sqlite-autoconf-$SQLITE3_VERSION;./configure --prefix=$PREFIX;make;make install) + fi + fi +fi +if ! [[ -e $PREFIX/bin/pg_config ]]; then + echo Install Postgresql + pgsql_tgz=postgresql-9.6.4.tar.gz + if ! [[ -e tgz/$pgsql_tgz ]]; then + wget -c https://ftp.postgresql.org/pub/source/v9.6.4/$pgsql_tgz + mv $pgsql_tgz tgz + fi + if ! [[ -e $PREFIX/bin/pg_config ]]; then + if [[ -e tgz/$pgsql_tgz ]]; then + tar xfz tgz/$pgsql_tgz + (cd postgresql-9.6.4; ./configure --prefix=$PREFIX --with-openssl; make; make install) + fi + fi +fi + + +cd $BUILDHOME +for egg in "sqlite3" sql-de-lite nanomsg +do + echo "Installing $egg" + CSC_OPTIONS="-I$PREFIX/include -L$PREFIX/lib -L$PREFIX/lib64" $CHICKEN_INSTALL $PROX -keep-installed $egg + #CSC_OPTIONS="-I$PREFIX/include -L$PREFIX/lib -L$PREFIX/lib64" $CHICKEN_INSTALL $PROX $egg + if [ $? -ne 0 ]; then + echo "$egg failed to install" + exit 1 + fi +done # Some eggs are quoted since they are reserved to Bash # for f in matchable readline apropos base64 regex-literals format "regex-case" "test" coops trace csv dot-locking posix-utils posix-extras directory-utils hostinfo tcp rpc csv-xml fmt json md5; do # $CHICKEN_INSTALL $PROX -keep-installed matchable readline apropos base64 regex-literals format "regex-case" "test" coops trace csv dot-locking posix-utils posix-extras directory-utils hostinfo tcp rpc csv-xml fmt json md5 awful http-client spiffy uri-common intarweb http-client spiffy-request-vars md5 message-digest http-client spiffy-directory-listing -$CHICKEN_INSTALL $PROX -keep-installed matchable readline apropos base64 regex-literals format "regex-case" "test" coops trace csv dot-locking posix-utils posix-extras directory-utils hostinfo tcp rpc csv-xml fmt json md5 awful http-client spiffy uri-common intarweb http-client spiffy-request-vars s md5 message-digest piffy-directory-listing ssax sxml-serializer sxml-modifications logpro -# if ! [[ -e $PREFIX/lib/chicken/6/$f.so ]];then -# $CHICKEN_INSTALL $PROX $f -# # $CHICKEN_INSTALL -deploy -prefix $DEPLOYTARG $PROX $f -# else -# echo Skipping install of egg $f as it is already installed -# fi -# done - -cd $BUILDHOME - -for a in `ls */*.meta|cut -f1 -d/` ; do - echo $a - (cd $a;$CHICKEN_INSTALL) -done - -export LIBPATH=$PREFIX/lib$ADDITIONAL_LIBPATH -export LD_LIBRARY_PATH=$LIBPATH - -export SQLITE3_VERSION=3071401 -echo Install sqlite3 -sqlite3_tgz=sqlite-autoconf-$SQLITE3_VERSION.tar.gz -if ! [[ -e tgz/$sqlite3_tgz ]]; then - wget http://www.sqlite.org/$sqlite3_tgz - mv $sqlite3_tgz tgz -fi - -if ! [[ -e $PREFIX/bin/sqlite3 ]] ; then - if [[ -e tgz/sqlite-autoconf-$SQLITE3_VERSION.tar.gz ]]; then - tar xfz tgz/sqlite-autoconf-$SQLITE3_VERSION.tar.gz - (cd sqlite-autoconf-$SQLITE3_VERSION;./configure --prefix=$PREFIX;make;make install) - # CSC_OPTIONS="-I$PREFIX/include -L$PREFIX/lib" $CHICKEN_INSTALL -prefix $DEPLOYTARG -deploy $PROX sqlite3 - CSC_OPTIONS="-I$PREFIX/include -L$PREFIX/lib" $CHICKEN_INSTALL $PROX sqlite3 - fi -fi - -# $CHICKEN_INSTALL $PROX sqlite3 - -# IUP versions -if [[ x$USEOLDIUP == "x" ]];then - CDVER=5.7 - IUPVER=3.8 - IMVER=3.8 -else - CDVER=5.7 - IUPVER=3.8 - IMVER=3.8 -fi +for egg in matchable readline apropos base64 regex-literals format "regex-case" "test" \ + coops trace csv dot-locking posix-utils posix-extras directory-utils hostinfo \ + tcp rpc csv-xml fmt json md5 awful http-client:0.7.1 spiffy uri-common intarweb http-client \ + spiffy-request-vars s md5 message-digest spiffy-directory-listing ssax sxml-serializer \ + sxml-modifications z3 call-with-environment-variables \ + pathname-expand typed-records \ + logpro \ + simple-exceptions numbers crypt parley srfi-42 \ + alist-lib ansi-escape-sequences args basic-sequences bindings chicken-doc chicken-doc-cmd \ + cock condition-utils debug define-record-and-printer easyffi easyffi-base \ + expand-full ezxdisp filepath foof-loop ini-file irc lalr lazy-seq \ + locale locale-builtin locale-categories locale-components locale-current locale-posix \ + locale-timezone loops low-level-macros procedural-macros refdb rfc3339 scsh-process \ + sexp-diff sha1 shell slice srfi-101 srfi-19 srfi-19-core srfi-19-date srfi-19-io \ + srfi-19-period srfi-19-support srfi-19-time srfi-19-timezone srfi-29 srfi-37 srfi-78 syslog \ + udp uuid uuid-lib zlib postgresql + +do + echo "Installing $egg" + $CHICKEN_INSTALL $PROX -keep-installed $egg + #$CHICKEN_INSTALL $PROX $egg + if [ $? -ne 0 ]; then + echo "$egg failed to install" + exit 1 + fi +done + +if [[ ! -e $PREFIX/lib/chicken/7/mysql-client.so ]];then + if [[ -e `which mysql_config` ]]; then + $CHICKEN_INSTALL $PROX mysql-client + fi +fi + +cd $BUILDHOME +cd `$PREFIX/bin/csi -p '(chicken-home)'` +curl http://3e8.org/pub/chicken-doc/chicken-doc-repo.tgz | tar zx +cd $BUILDHOME + +# $CHICKEN_INSTALL $PROX sqlite3 +cd $BUILDHOME if [[ `uname -a | grep x86_64` == "" ]]; then export ARCHSIZE='' else export ARCHSIZE=64_ fi # export files="cd-5.4.1_Linux${KTYPE}_lib.tar.gz im-3.6.3_Linux${KTYPE}_lib.tar.gz iup-3.5_Linux${KTYPE}_lib.tar.gz" if [[ x$USEOLDIUP == "x" ]];then - export files="cd-${CDVER}_Linux${KTYPE}_${ARCHSIZE}lib.tar.gz im-${IMVER}_Linux${KTYPE}_${ARCHSIZE}lib.tar.gz iup-${IUPVER}_Linux${KTYPE}_${ARCHSIZE}lib.tar.gz" -else - echo WARNING: Using old IUP libraries - export files="cd-5.4.1_Linux${KTYPE}_${ARCHSIZE}lib.tar.gz im-3.6.3_Linux${KTYPE}_${ARCHSIZE}lib.tar.gz iup-3.5_Linux${KTYPE}_${ARCHSIZE}lib.tar.gz" -fi - -mkdir -p $PREFIX/iuplib -for a in `echo $files` ; do - if ! [[ -e tgz/$a ]] ; then - wget http://www.kiatoa.com/matt/iup/$a - mv $a tgz/$a - fi - echo Untarring tgz/$a into $BUILDHOME/lib - (cd $PREFIX/lib;tar xfvz $BUILDHOME/tgz/$a;mv include/* ../include) - # (cd $DEPLOYTARG;tar xfvz $BUILDHOME/$a) -done - -# ffcall obtained from: -# cvs -z3 -d:pserver:anonymous@cvs.savannah.gnu.org:/sources/libffcall co ffcall - -if ! [[ -e tgz/ffcall.tar.gz ]] ; then - wget http://www.kiatoa.com/matt/iup/ffcall.tar.gz - mv ffcall.tar.gz tgz -fi - -tar xfvz tgz/ffcall.tar.gz - -cd ffcall -./configure --prefix=$PREFIX --enable-shared -make -make install - - -cd $BUILDHOME -export CSCLIBS=`echo $LD_LIBRARY_PATH | sed 's/:/ -L/g'` -CSC_OPTIONS="-I$PREFIX/include -L$CSCLIBS" $CHICKEN_INSTALL $PROX -D no-library-checks -feature disable-iup-web iup -# CSC_OPTIONS="-I$PREFIX/include -L$CSCLIBS" $CHICKEN_INSTALL $PROX -D no-library-checks -feature disable-iup-web -deploy -prefix $DEPLOYTARG iup -# iup:1.0.2 -CSC_OPTIONS="-I$PREFIX/include -L$CSCLIBS" $CHICKEN_INSTALL $PROX -D no-library-checks canvas-draw -# CSC_OPTIONS="-I$PREFIX/include -L$CSCLIBS" $CHICKEN_INSTALL $PROX -D no-library-checks -deploy -prefix $DEPLOYTARG canvas-draw - -# NB// Removed bunch of zmq compiling tricks. Look at older versions of this file if you need to recreate... - -cd $BUILDHOME - -# git clone https://bitbucket.org/DerGuteMoritz/zmq/commits/branch/3.2 zmq-3.2 -# cd zmq-3.2 -# chicken-install -# -# cd $BUILDHOME - -## WEBKIT=WebKit-r131972 -## if ! [[ -e ${WEBKIT}.tar.bz2 ]] ; then -## # http://builds.nightly.webkit.org/files/trunk/src/WebKit-r131972.tar.bz2 -## wget http://builds.nightly.webkit.org/files/trunk/src/${WEBKIT}.tar.bz2 -## fi -## -## if [[ x$only_it_worked == $I_wish ]] ;then -## if [[ -e ${WEBKIT}.tar.bz2 ]] ; then -## tar xfj ${WEBKIT}.tar.bz2 -## cd $WEBKIT -## ./autogen.sh -## ./configure --prefix=$PREFIX -## make -## make install -## fi -## fi -## -## cd $BUILHOME - -# export CD_REL=d704525ebe1c6d08 -# if ! [[ -e Canvas_Draw-$CD_REL.zip ]]; then -# wget http://www.kiatoa.com/matt/iup/Canvas_Draw-$CD_REL.zip -# fi -# -# unzip -o Canvas_Draw-$CD_REL.zip -# -# cd "Canvas Draw-$CD_REL/chicken" -# CSC_OPTIONS="-I$PREFIX/include -L$LIBPATH" $CHICKEN_INSTALL $PROX -D no-library-checks - -echo You may need to add $LD_LIBRARY_PATH to your LD_LIBRARY_PATH variable, a setup-chicken4x.sh -echo file can be found in the current directory which should work for setting up to run chicken4x - -echo Testing iup -$PREFIX/bin/csi -b -eval '(use iup)(print "Success")' + export files="cd/cd-${CDVER}_Linux${KTYPE}_${ARCHSIZE}lib.tar.gz im/im-${IMVER}_Linux${KTYPE}_${ARCHSIZE}lib.tar.gz iup/iup-${IUPVER}_Linux${KTYPE}_${ARCHSIZE}lib.tar.gz" +else + echo WARNING: Using old IUP libraries + export files="cd/cd-5.4.1_Linux${KTYPE}_${ARCHSIZE}lib.tar.gz im/im-3.6.3_Linux${KTYPE}_${ARCHSIZE}lib.tar.gz iup/iup-3.5_Linux${KTYPE}_${ARCHSIZE}lib.tar.gz" +fi +echo $files + +mkdir -p $PREFIX/iuplib +mkdir -p iup/ +for a in $files ; do + targfile=$(echo $a | cut -d'/' -f2) + if ! [[ -e tgz/$a ]] ; then + echo wget -c -O tgz/$a http://www.kiatoa.com/matt/chicken-build/$a + wget -c http://www.kiatoa.com/matt/chicken-build/$a + mv $targfile tgz/ + fi + if ! [[ -e tgz/$targfile ]] ; then + echo "ERROR: Failed to get http://www.kiatoa.com/matt/chicken-build/$a, please report this to matt@kiatoa.com" + exit 1 + fi + echo Untarring tgz/$targfile into $BUILDHOME/lib + tar -xzf tgz/$targfile -C iup/ +done + +cp iup/include/* $PREFIX/include/ +cp iup/*.so $PREFIX/lib/ +cp iup/*.a $PREFIX/lib/ +cp iup/ftgl/lib/*/* $PREFIX/lib/ +cd $BUILDHOME +# ffcall obtained from: +# cvs -z3 -d:pserver:anonymous@cvs.savannah.gnu.org:/sources/libffcall co ffcall +#exit +if ! [[ -e $PREFIX/include/callback.h ]] ; then + #fossil clone http://www.kiatoa.com/fossils/ffcall ffcall.fossil + wget -c -O ffcall.tar.gz 'http://www.kiatoa.com/fossils/ffcall/tarball?name=ffcall&uuid=trunk' + tar -xzf ffcall.tar.gz + #mkdir -p ffcall + cd ffcall + #fossil open ../ffcall.fossil + ./configure --prefix=$PREFIX --enable-shared + make CC="gcc -fPIC" + make install +fi +cd $BUILDHOME +#wget -c -O opensrc.tar.gz 'http://www.kiatoa.com/fossils/opensrc/tarball?name=opensrc&uuid=trunk' +# Not working due to login problems. +if ! [[ -e $PREFIX/bin/hs ]] ; then + #fossil clone http://www.kiatoa.com/fossils/opensrc opensrc.fossil + #mkdir -p opensrc + wget -c -O opensrc.tar.gz 'http://www.kiatoa.com/fossils/opensrc/tarball?name=opensrc&uuid=trunk' + tar -xzf opensrc.tar.gz + cd opensrc + #fossil open ../opensrc.fossil + cd histstore + $PREFIX/bin/csc histstore.scm -o hs + cp -f hs $PREFIX/bin/hs + cd ../mutils + $PREFIX/bin/chicken-install + cd ../dbi + $PREFIX/bin/chicken-install + cd ../margs + $PREFIX/bin/chicken-install + cd ../pkts + $PREFIX/bin/chicken-install +fi +cd $BUILDHOME + +if [[ ! -e $PREFIX/bin/stmlrun ]] ; then + #fossil clone http://www.kiatoa.com/fossils/stml stml.fossil + wget -c -O stml.tar.gz 'http://www.kiatoa.com/fossils/stml/tarball?name=stml&uuid=trunk' + tar -xzf stml.tar.gz + cd stml + #fossil open ../stml.fossil + cp install.cfg.template install.cfg + echo "TARGDIR=$PREFIX/bin" > install.cfg + echo "LOGDIR=/tmp/stmlrun" >> install.cfg + echo "SQLITE3=$PREFIX/bin/sqlite3" >> install.cfg + cp requirements.scm.template requirements.scm + which csc + make clean + CSCOPTS="-C -fPIC" make +fi + +cd $BUILDHOME +export CSCLIBS=`echo $LD_LIBRARY_PATH | sed 's/:/ -L/g'` +IUPEGGVER='iup' +if [[ $IUPVER == "3.5" ]]; then + IUPEGGVER='iup:1.2.1' +fi + +#CSC_OPTIONS="-I$PREFIX/include -L$CSCLIBS" $CHICKEN_INSTALL $PROX -D no-library-checks -feature disable-iup-web iup +CSC_OPTIONS="-I$PREFIX/include -L$PREFIX/lib" $CHICKEN_INSTALL $PROX -D no-library-checks -feature disable-iup-web -feature disable-iup-pplot $IUPEGGVER + +# CSC_OPTIONS="-I$PREFIX/include -L$CSCLIBS" $CHICKEN_INSTALL $PROX -D no-library-checks -feature disable-iup-web -deploy -prefix $DEPLOYTARG iup +# iup:1.0.2 +CSC_OPTIONS="-I$PREFIX/include -L$PREFIX/lib" $CHICKEN_INSTALL $PROX -D no-library-checks canvas-draw +# CSC_OPTIONS="-I$PREFIX/include -L$CSCLIBS" $CHICKEN_INSTALL $PROX -D no-library-checks -deploy -prefix $DEPLOYTARG canvas-draw + +cd $BUILDHOME + +# install ducttape +if [[ -e ../ducttape ]];then + cd ../ducttape + $CHICKEN_INSTALL +else + echo "ducttape egg not found at ../ducttape. You will need to cd into the ducttape directory in the megatest distribution and run \"chicken-install\"" +fi + +cd $BUILDHOME +echo You may need to add $LD_LIBRARY_PATH to your LD_LIBRARY_PATH variable, a setup-chicken4x.sh +echo file can be found in the current directory which should work for setting up to run chicken4x + + +echo Testing iup +$PREFIX/bin/csi -b -eval '(use iup)(print "Success")' + + Index: utils/installck.sh ================================================================== --- utils/installck.sh +++ utils/installck.sh @@ -1,7 +1,24 @@ #!/bin/bash +# Copyright 2006-2017, Matthew Welland. +# +# This file is part of Megatest. +# +# Megatest is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# Megatest is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with Megatest. If not, see . + myhome=$(dirname $0) if [[ $proxy == "" ]]; then echo 'Please set the environment variable "proxy" to host.com:port (e.g. foo.com:1234) to use a proxy' echo PROX="" Index: utils/loadrunner ================================================================== --- utils/loadrunner +++ utils/loadrunner @@ -1,7 +1,24 @@ #!/bin/bash +# Copyright 2006-2017, Matthew Welland. +# +# This file is part of Megatest. +# +# Megatest is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# Megatest is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with Megatest. If not, see . + LOADRUNNER=$0 # load=`uptime|awk '{print $10}'|cut -d, -f1` load=$(uptime|perl -pe 's/.*: (\d+.\d+),.*/$1/') load2=$(uptime|perl -pe 's/.*: (\d+.\d+), (\d+.\d+),.*/$2/') Index: utils/loadrunner.scm.notfinished ================================================================== --- utils/loadrunner.scm.notfinished +++ utils/loadrunner.scm.notfinished @@ -1,14 +1,22 @@ ;; Copyright 2006-2013, Matthew Welland. ;; -;; This program is made available under the GNU GPL version 2.0 or -;; greater. See the accompanying file COPYING for details. +;; This file is part of Megatest. +;; +;; Megatest is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. +;; +;; Megatest is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. ;; -;; This program is distributed WITHOUT ANY WARRANTY; without even the -;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR -;; PURPOSE. +;; You should have received a copy of the GNU General Public License +;; along with Megatest. If not, see . (use ssax) (use sxml-serializer) (use sxml-modifications) (use regex) ADDED utils/lock-stats.sh Index: utils/lock-stats.sh ================================================================== --- /dev/null +++ utils/lock-stats.sh @@ -0,0 +1,30 @@ +#!/bin/bash + +# Copyright 2006-2017, Matthew Welland. +# +# This file is part of Megatest. +# +# Megatest is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# Megatest is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with Megatest. If not, see . + +while IFS=': ' read x x x x p x x i x; do + if ! [[ ${i}x == "x" ]];then + if ! $(echo $i|grep EOF >/dev/null);then + fname=$(find -L "/proc/$p/fd" -maxdepth 1 -inum "$i" -exec readlink {} \; -quit) + if $(echo $fname | grep megatest.db > /dev/null) || \ + $(echo $fname | egrep '.db/\d+.db' > /dev/null);then + echo $fname + fi + fi + fi +done < /proc/locks ADDED utils/memproblem.scm Index: utils/memproblem.scm ================================================================== --- /dev/null +++ utils/memproblem.scm @@ -0,0 +1,65 @@ +;; Copyright 2006-2017, Matthew Welland. +;; +;; This file is part of Megatest. +;; +;; Megatest is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. +;; +;; Megatest is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with Megatest. If not, see . +;; +;; Run like this: ((adjust the "30" number to a value that fills memory on the machine you are using) +;; script -c "free -g ; utils/memproblem 30 -:hm128G" memclean.log + +;; Fill the cache with something like this: +;; find /path/to/lots/of/files/ -type f -exec cat {} > /dev/null \; + + +(use posix numbers srfi-4) + +(define num-iter (or (if (> (length (argv)) 2) + (string->number (cadr (argv))) + #f) + 43)) ;; Gigs memory to try to allocate +;; (print "Allocating up to " memsize "G memory. Note that due to the usage of the heap this will actually use up to " (* 2 memsize) "G") + +(define (get-free) + (let ((indat (with-input-from-pipe + "free" + read-lines))) + (map string->number + (cdr + (string-split + (cadr indat)))))) + +(define-inline (cached dat)(list-ref dat 5)) +(define-inline (used dat)(list-ref dat 1)) +(define-inline (free dat)(list-ref dat 2)) + +(define-inline (k->G val)(/ val 1e6)) +(define-inline (G->k val)(* val 1e6)) + +(define start-time (current-milliseconds)) + +(let loop ((n 0) + (dat (get-free)) + (stuff '())) + (let ((bigvec (make-u32vector 200000000)) + (startt (current-milliseconds))) + (print "Value at 100: " (u32vector-ref bigvec 100) " ms to access: " (- (current-milliseconds) startt)) + (u32vector-set! bigvec (random 190000000) 111) + (print n " Elapsed time: " (/ (- (current-milliseconds) start-time) 1000) " s " + "Cached: " (k->G (cached dat)) " G " + "Used: " (k->G (used dat)) " G ") + (if (< n num-iter) + (loop (+ n 1)(get-free) (cons bigvec stuff))))) + +(exit) + Index: utils/mk_wrapper ================================================================== --- utils/mk_wrapper +++ utils/mk_wrapper @@ -1,36 +1,76 @@ #!/bin/bash +# Copyright 2006-2017, Matthew Welland. +# +# This file is part of Megatest. +# +# Megatest is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# Megatest is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with Megatest. If not, see . + prefix=$1 cmd=$2 target=$3 +cfgfile="$prefix/bin/.$(lsb_release -sr)/cfg.sh" +libdir="$prefix/bin/.$(lsb_release -sr)/lib" + +# we wish to create a var in cfg.sh for finding sqlite3 executable +chicken_bin_dir=$(dirname $(which csi)) +if [[ -e $chicken_bin_dir/sqlite3 ]];then + sqlite3_exe=$chicken_bin_dir/sqlite3 +else + sqlite3_exe=$(which sqlite3) +fi if [ "$LD_LIBRARY_PATH" != "" ];then - cfgfile="$prefix/bin/.$(lsb_release -sr)/cfg.sh" echo "INFO: Using LD_LIBRARY_PATH=$LD_LIBRARY_PATH" >&2 + echo "INFO: Writing $cfgfile" >&2 ( cat << __EOF +if [ -z \$MT_ORIG_ENV ]; then + export MT_ORIG_ENV=\$( $prefix/bin/serialize-env ) +fi + if [ "\$LD_LIBRARY_PATH" != "" ];then - export LD_LIBRARY_PATH=$LD_LIBRARY_PATH:\$LD_LIBRARY_PATH + export LD_LIBRARY_PATH=$LD_LIBRARY_PATH:\$LD_LIBRARY_PATH:$libdir else - export LD_LIBRARY_PATH=$LD_LIBRARY_PATH + export LD_LIBRARY_PATH=$LD_LIBRARY_PATH:$libdir fi + +export MT_SQLITE3_EXE=$sqlite3_exe __EOF ) > $cfgfile echo else echo "INFO: LD_LIBRARY_PATH not set" >&2 fi -# echo "#!/bin/bash" > $target -# if [ "$LD_LIBRARY_PATH" != "" ];then -# echo "source $prefix/bin/.\$(lsb_release -sr)/cfg.sh" >> $target -# fi -# echo "exec $prefix/bin/.\$(lsb_release -sr)/$cmd \"\$@\"" >> $target echo "#!/bin/bash" > $target if [[ $cmd =~ dboard ]]; then cat >> $target <<'EOF' + +# # disable if not running on homehost +# if [[ -e .homehost ]]; then +# homehostname=$( host `cat .homehost` | awk '{print $NF}' | sed 's/\.$//' ) +# hostname=$( hostname -f ) +# +# if [[ ! ($homehostname == $hostname) ]]; then +# echo "ERROR: this host ($hostname) is not the homehost ($homehostname) for this megatest run area. Cannot start dashboard." +# echo " Please log into homehost before launching dashboard." +# exit 1 +# fi +# fi # check that $DISPLAY is set if [[ -z $DISPLAY ]]; then echo 'ERROR: $DISPLAY environment variable is not set; megatest dashboard requires X display address to be set in $DISPLAY.' exit 1 @@ -45,8 +85,19 @@ fi EOF fi +cat >> $target << EOF +if [[ \$(ulimit -a | grep 'open files' | awk '{print \$4}') -gt 10000 ]];then ulimit -n 10000;fi +EOF + +# echo "#!/bin/bash" > $target +# echo "exec $prefix/bin/.\$(lsb_release -sr)/$cmd \"\$@\"" >> $target + echo "lsbr=\$(lsb_release -sr)" >> $target -echo "if [[ -e \$lsbr ]];then source \$lsbr;fi" >> $target +if [ "$LD_LIBRARY_PATH" != "" ];then + echo "source $prefix/bin/.\$lsbr/cfg.sh" >> $target +fi + +# echo "if [[ -e \$lsbr ]];then source \$lsbr;fi" >> $target echo "exec $prefix/bin/.\$lsbr/$cmd \"\$@\"" >> $target ADDED utils/mk_wrapper_tool Index: utils/mk_wrapper_tool ================================================================== --- /dev/null +++ utils/mk_wrapper_tool @@ -0,0 +1,101 @@ +#!/bin/bash + +# Copyright 2006-2017, Matthew Welland. +# +# This file is part of Megatest. +# +# Megatest is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# Megatest is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with Megatest. If not, see . + +prefix=$1 +cmd=$2 +target=$3 +cfgfile="$prefix/bin/.$(lsb_release -sr)/cfg.sh" + +# we wish to create a var in cfg.sh for finding sqlite3 executable +chicken_bin_dir=$(dirname $(which csi)) +if [[ -e $chicken_bin_dir/sqlite3 ]];then + sqlite3_exe=$chicken_bin_dir/sqlite3 +else + sqlite3_exe=$(which sqlite3) +fi + +if [ "$LD_LIBRARY_PATH" != "" ];then + echo "INFO: Using LD_LIBRARY_PATH=$LD_LIBRARY_PATH" >&2 +( cat << __EOF +if [ -z \$MT_ORIG_ENV ]; then + export MT_ORIG_ENV=\$( $prefix/bin/serialize-env ) +fi + +if [ "\$LD_LIBRARY_PATH" != "" ];then + export LD_LIBRARY_PATH=$LD_LIBRARY_PATH:\$LD_LIBRARY_PATH +else + export LD_LIBRARY_PATH=$LD_LIBRARY_PATH +fi + +export MT_SQLITE3_EXE=$sqlite3_exe +__EOF +) > $cfgfile + echo +else + echo "INFO: LD_LIBRARY_PATH not set" >&2 +fi + +echo "#!/bin/bash" > $target + +if [[ $cmd =~ dboard ]]; then + cat >> $target <<'EOF' + +# # disable if not running on homehost +# if [[ -e .homehost ]]; then +# homehostname=$( host `cat .homehost` | awk '{print $NF}' | sed 's/\.$//' ) +# hostname=$( hostname -f ) +# +# if [[ ! ($homehostname == $hostname) ]]; then +# echo "ERROR: this host ($hostname) is not the homehost ($homehostname) for this megatest run area. Cannot start dashboard." +# echo " Please log into homehost before launching dashboard." +# exit 1 +# fi +# fi + +# check that $DISPLAY is set +if [[ -z $DISPLAY ]]; then + echo 'ERROR: $DISPLAY environment variable is not set; megatest dashboard requires X display address to be set in $DISPLAY.' + exit 1 +fi + +# check that $DISPLAY is proper +if [[ -x $(which xdpyinfo 2>/dev/null) ]]; then + if ! xdpyinfo -display "$DISPLAY" &>/dev/null; then + echo 'ERROR: megatest dashboard cannot open display "'$DISPLAY'". Please check $DISPLAY environment variable.' + exit 1 + fi +fi +EOF + +fi + +cat >> $target << EOF +if [[ \$(ulimit -a | grep 'open files' | awk '{print \$4}') -gt 10000 ]];then ulimit -n 10000;fi +EOF + +# echo "#!/bin/bash" > $target +# echo "exec $prefix/bin/.\$(lsb_release -sr)/bin/$cmd \"\$@\"" >> $target + +echo "lsbr=\$(lsb_release -sr)" >> $target +if [ "$LD_LIBRARY_PATH" != "" ];then + echo "source $prefix/bin/.\$lsbr/cfg.sh" >> $target +fi + +# echo "if [[ -e \$lsbr ]];then source \$lsbr;fi" >> $target +echo "exec $chicken_bin_dir/$cmd \"\$@\"" >> $target Index: utils/mt_ezstep ================================================================== --- utils/mt_ezstep +++ utils/mt_ezstep @@ -1,18 +1,26 @@ #!/bin/bash -usage="mt_ezstep stepname prevstepname command [args ...]" - -if [[ "$MT_CMDINFO" == "" ]];then - if [[ -e megatest.sh ]];then - source megatest.sh - else - echo "ERROR: $0 should be run within a megatest test environment" - echo "Usage: $usage" - exit - fi -fi +# Copyright 2006-2017, Matthew Welland. +# +# This file is part of Megatest. +# +# Megatest is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# Megatest is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with Megatest. If not, see . + +usage="mt_ezstep stepname command [args ...]" + # Purpose: This is for the [ezsteps] secton in your testconfig file. # DO NOT USE IN YOUR SCRIPTS! # # Call like this: @@ -24,16 +32,15 @@ fi # Since the user may not have . on the path and since we are likely to want to # run test scripts in the current directory add the current dir to the path export PATH=$PATH:$PWD - +testrundir=$1; shift stepname=$1;shift -prevstepname=$1;shift + command=$* - allstatus=99 runstatus=99 logpropstatus=99 # prev_env=".ezsteps/${prevstepname}.sh" @@ -41,39 +48,36 @@ # if [[ -e "${prev_env}" ]];then # source $prev_env # fi # source the environment from the previous step if it exists +cd $testrundir +#if [[ "$MT_CMDINFO" == "" ]];then + if [[ -e megatest.sh ]];then + source megatest.sh + else + echo "ERROR: $0 should be run within a megatest test environment" + echo "Usage: $usage" + exit + fi +#fi + + # if a logpro file exists then use it otherwise just run the command, nb// was using 2>&1 if [[ -e ${stepname}.logpro ]];then - # could do: - $command 2>&1| tee ${stepname}.log | logpro ${stepname}.logpro ${stepname}.html &> /dev/null - logprostatus=$? - # $command 2>&1| logpro ${stepname}.logpro ${stepname}.html &> ${stepname}.log - # allstatus=(${PIPESTATUS[0]} ${PIPESTATUS[1]}) - allstatus=(${PIPESTATUS[0]} ${PIPESTATUS[1]}) - runstatus=${allstatus[0]} - # logprostatus=${allstatus[1]} -else - $command &> ${stepname}.log - runstatus=$? - logprostatus=$runstatus -fi - -# If the test exits with non-zero, we will record FAIL even if logpro -# says it is a PASS - -if [[ $runstatus -ne 0 ]]; then - exitstatus=$runstatus -elif [[ $logprostatus -eq 0 ]]; then - exitstatus=$logprostatus -elif [[ $logprostatus -eq 2 ]]; then - exitstatus=2 -elif [[ $logprostatus -eq 1 ]]; then - exitstatus=1 -else - exitstatus=0 -fi - -# $MT_MEGATEST -env2file .ezsteps/${stepname} + eval $command 2>&1 ${stepname}.log + runstatus=$? + logpro ${stepname}.logpro ${stepname}.html &> /dev/null < ${stepname}.log + logprostatus=$? + + if [[ $runstatus == 0 ]]; then + exitstatus=$logprostatus + else + exitstatus=$runstatus + fi +else + eval $command &> ${stepname}.log + exitstatus=$? +fi + exit $exitstatus Index: utils/mt_laststep ================================================================== --- utils/mt_laststep +++ utils/mt_laststep @@ -1,7 +1,24 @@ #!/bin/bash +# Copyright 2006-2017, Matthew Welland. +# +# This file is part of Megatest. +# +# Megatest is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# Megatest is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with Megatest. If not, see . + if [ $MT_CMDINFO == "" ];then echo "ERROR: $0 should be run within a megatest test environment" exit fi Index: utils/mt_runstep ================================================================== --- utils/mt_runstep +++ utils/mt_runstep @@ -1,7 +1,24 @@ #!/bin/bash +# Copyright 2006-2017, Matthew Welland. +# +# This file is part of Megatest. +# +# Megatest is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# Megatest is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with Megatest. If not, see . + # Purpose: run a step, record start and end with exit codes # # Call like this: # mt_runstep stepname command .... # Index: utils/mt_xterm ================================================================== --- utils/mt_xterm +++ utils/mt_xterm @@ -1,7 +1,24 @@ #!/bin/bash +# Copyright 2006-2017, Matthew Welland. +# +# This file is part of Megatest. +# +# Megatest is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# Megatest is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with Megatest. If not, see . + MT_TMPDISPLAY=$DISPLAY if [ -e megatest.sh ];then source megatest.sh fi export DISPLAY=$MT_TMPDISPLAY Index: utils/mtgetfile ================================================================== --- utils/mtgetfile +++ utils/mtgetfile @@ -1,7 +1,24 @@ #!/bin/bash +# Copyright 2006-2017, Matthew Welland. +# +# This file is part of Megatest. +# +# Megatest is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# Megatest is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with Megatest. If not, see . + fullparams="$@" function findfile () { megatest $fullparams -repl <. + +# Rollup counts of calls to Megatest from a logging dat file +# +# Usage: mtrept.sh file [host] + +if [[ "$2"x != "x" ]];then + host_name_grep="grep $2 | " +else + host_name_grep="" +fi +if [[ "$1"x == "x" ]];then + datfile=/p/fdk/gwa/$USER/.logger/all.dat +else + datfile=$1 +fi +datcopy=/tmp/$USER/all.$PID.dat + +if [[ -e $datfile ]];then + cp $datfile $datcopy + list_runs=$(grep list-runs $datcopy |$host_name_grep wc -l) + show_config=$(grep show-config $datcopy |$host_name_grep wc -l) + list_targets=$(grep list-targets $datcopy |$host_name_grep wc -l) + mt_run=$(grep ' -run ' $datcopy |$host_name_grep wc -l) + execute=$(grep ' -execute' $datcopy|$host_name_grep wc -l) + server=$(grep ' -server' $datcopy|$host_name_grep wc -l) + sync_to=$(grep ' -sync-to' $datcopy|$host_name_grep wc -l) + step=$(grep ' -step' $datcopy|$host_name_grep wc -l) + state_status=$(grep ' -set-state-status' $datcopy|$host_name_grep wc -l) + test_status=$(grep ' -test-status' $datcopy|$host_name_grep wc -l) + other=$(egrep -v ' -(list-runs|show-config|list-targets|run|execute|server|sync-to|step|set-state-status|test-status)' $datcopy |$host_name_grep wc -l) + start_time=$(head -1 $datcopy|awk '{print $1}') + end_time=$(tail -1 $datcopy | awk '{print $1}') + minutes=$(echo "($end_time-$start_time)/60.0" | bc) + hours=$(echo "($minutes/60)"|bc) + total_calls=$(cat $datcopy |$host_name_grep wc -l) + + if [[ $hours -gt 2 ]];then + echo "Over $hours hour period we have;" + else + echo "Over $minutes minutes we have;" + fi + echo " list-runs: $list_runs" + echo " show-config: $show_config" + echo " list-targets: $list_targets" + echo " execute: $execute" + echo " run: $mt_run" + echo " server: $server" + echo " step: $step" + echo " test-status: $test_status" + echo " sync-to: $sync_to" + echo " state-status: $state_status" + echo " other: $other" + echo " total: $total_calls" +else + echo "Could not find input file $datfile" +fi + Index: utils/mtrunner ================================================================== --- utils/mtrunner +++ utils/mtrunner @@ -1,7 +1,24 @@ #! /bin/bash +# Copyright 2006-2017, Matthew Welland. +# +# This file is part of Megatest. +# +# Megatest is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# Megatest is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with Megatest. If not, see . + # Run megatest from within megatest # Usage: mtrunner testsuite_dir megatest_bin_dir command args .... for var in $(env | egrep "^MT_"|cut -d= -f1);do unset ${var} @@ -9,6 +26,6 @@ cd $1 shift export PATH="$1:$PATH" shift -"$@" +exec "$@" Index: utils/mtrunscript ================================================================== --- utils/mtrunscript +++ utils/mtrunscript @@ -1,17 +1,23 @@ #!/usr/bin/env bash # Copyright 2012, Matthew Welland. -# -# This program is made available under the GNU GPL version 2.0 or -# greater. See the accompanying file COPYING for details. -# -# This program is distributed WITHOUT ANY WARRANTY; without even the -# implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR -# PURPOSE. -# -# VERSION: + +# This file is part of Megatest. +# +# Megatest is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# Megatest is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with Megatest. If not, see . # set -e # set -u # set -x Index: utils/mtutils.csh ================================================================== --- utils/mtutils.csh +++ utils/mtutils.csh @@ -1,8 +1,25 @@ # Better to use the mt_* snippet scripts in utils # To use the snippets set PREFIX then install with "make installall" +# Copyright 2006-2017, Matthew Welland. +# +# This file is part of Megatest. +# +# Megatest is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# Megatest is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with Megatest. If not, see . + alias mt_runstep 'set argv=(\!*); \ set stepname = $1;shift; \ megatest -runstep $stepname -logpro ${stepname}.logpro "$*" || exit $?' alias mt_laststep 'set argv=(\!*);set stepname = $1;shift; \ Index: utils/nbfake ================================================================== --- utils/nbfake +++ utils/nbfake @@ -1,13 +1,33 @@ #!/bin/bash + +# Copyright 2006-2017, Matthew Welland. +# +# This file is part of Megatest. +# +# Megatest is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# Megatest is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with Megatest. If not, see . + ############################################################################### # # nbfake - capture command output in a logfile # # nbfake behavior can be changed by setting the following env vars: # NBFAKE_HOST SSH to $NBFAKE_HOST and run command # NBFAKE_LOG Logfile for nbfake output +# NB_WASH_GROUPS comma-separated list of groups to wash into +# NB_WASH_ENABLED must be set in order to enable wash groups # ############################################################################### if [[ -z "$@" ]]; then cat <<__EOF @@ -17,10 +37,12 @@ nbfake nbfake behavior can be changed by setting the following env vars: NBFAKE_HOST SSH to \$NBFAKE_HOST and run command NBFAKE_LOG Logfile for nbfake output + NB_WASH_GROUPS comma-separated list of groups to wash into + NB_WASH_ENABLED must be set in order to enable wash groups __EOF exit fi @@ -53,24 +75,31 @@ # Set default nbfake log if [[ -z "$MY_NBFAKE_LOG" ]]; then MY_NBFAKE_LOG=NBFAKE-$(date +%GWW%V.%u_%T) fi + +# wash groups handling. Default is no action +WASHCMD="" +if [[ -n ${NB_WASH_ENABLED+1} && -n ${NB_WASH_GROUPS+1} ]]; then + grouplist=`echo $NB_WASH_GROUPS | tr ',' ' '` + WASHCMD="wash -q -n $grouplist -X" +fi #============================================================================== # Run and log #============================================================================== cat <<__EOF >&2 #====================================================================== # NBFAKE logging command to: $MY_NBFAKE_LOG -# $* +# $WASHCMD $* #====================================================================== __EOF if [[ -z "$MY_NBFAKE_HOST" ]]; then # Run locally - sh -c "cd $CURRWD;export DISPLAY=$DISPLAY; export PATH=$PATH; nohup $* >> $MY_NBFAKE_LOG 2>&1 &" + sh -c "cd $CURRWD;export DISPLAY=$DISPLAY; export PATH=$PATH; nohup $WASHCMD $* >> $MY_NBFAKE_LOG 2>&1 &" else # run remotely - ssh -n -f $MY_NBFAKE_HOST "sh -c \"cd $CURRWD;export DISPLAY=$DISPLAY; export PATH=$PATH; nohup $* >> $MY_NBFAKE_LOG 2>&1 &\"" + ssh -X -n -f $MY_NBFAKE_HOST "sh -c \"cd $CURRWD;export DISPLAY=$DISPLAY; export PATH=$PATH; nohup $WASHCMD $* >> $MY_NBFAKE_LOG 2>&1 &\"" fi Index: utils/nbfind ================================================================== --- utils/nbfind +++ utils/nbfind @@ -1,7 +1,24 @@ #!/bin/bash +# Copyright 2006-2017, Matthew Welland. +# +# This file is part of Megatest. +# +# Megatest is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# Megatest is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with Megatest. If not, see . + # load=`uptime|awk '{print $10}'|cut -d, -f1` load=`uptime|perl -pe 's/.*: (\d+.\d+),.*/$1/'` if which cpucheck > /dev/null;then numcpu=`cpucheck|tail -1|awk '{print $6}'` else Index: utils/plot-code.scm ================================================================== --- utils/plot-code.scm +++ utils/plot-code.scm @@ -1,6 +1,24 @@ #!/mfs/pkgs/chicken/4.8.0.5/bin/csi -nbq + +;; Copyright 2006-2017, Matthew Welland. +;; +;; This file is part of Megatest. +;; +;; Megatest is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. +;; +;; Megatest is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with Megatest. If not, see . +;; ;; Coming soon (right?) Usage: plot-code file1.scm,file2.scm "fun1,fun2,x*" *.scm > plot.dot ;; Usage: plot-code file1.scm,file2.scm *.scm > plot.dot ;; dot -Tpdf plot.dot > plot.pdf ;; first param is comma separated list of files to include in the map, use - to do all @@ -8,17 +26,19 @@ ;; third param is list of files to scan (use regex srfi-69 srfi-13) (define targs #f) -(define files (cddddr (argv))) +(define files (cdr (cddddr (argv)))) (let ((targdat (cadddr (argv)))) (if (equal? targdat "-") (set! targs files) (set! targs (string-split targdat ",")))) +(define function-patt (car (cdr (cdddr (argv))))) +(define function-rx (regexp function-patt)) (define filedat-defns (make-hash-table)) (define filedat-usages (make-hash-table)) (define defn-rx (regexp "^\\s*\\(define\\s+\\(([^\\s\\)]+).*")) (define all-regexs (make-hash-table)) @@ -32,10 +52,11 @@ (lambda () (apply print data)))) (print-err "Making graph for files: " (string-intersperse targs ", ")) (print-err "Looking at files: " (string-intersperse files ", ")) +(print-err "Function regex: " function-patt) ;; Gather the functions ;; (for-each (lambda (fname) @@ -46,16 +67,18 @@ (if (not (eof-object? inl)) (let ((match (string-match defn-rx inl))) (if match (let ((fnname (cadr match))) ;; (print " " fnname) - (set! all-fns (cons fnname all-fns)) - (hash-table-set! - filedat-defns - fname - (cons fnname (hash-table-ref/default filedat-defns fname '()))) - )) + (if (string-match function-rx fnname) + (begin + (set! all-fns (cons fnname all-fns))) + (hash-table-set! + filedat-defns + fname + (cons fnname (hash-table-ref/default filedat-defns fname '()))) + ))) (loop (read-line)))))))) files) ;; fill up the regex hash (print-err "Make the huge regex hash") ADDED utils/remrun Index: utils/remrun ================================================================== --- /dev/null +++ utils/remrun @@ -0,0 +1,51 @@ +#!/bin/bash +############################################################################### +# +# remrun - same behavior as nbfake but first param is a hosthane +# (capture command output in a logfile) +# +# remrun behavior can be changed by setting the following env var: +# NBFAKE_LOG Logfile for nbfake output +# +############################################################################### +# +# Copyright 2006-2017, Matthew Welland. +# +# This file is part of Megatest. +# +# Megatest is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# Megatest is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with Megatest. If not, see . + +if [[ -z "$@" ]]; then + cat <<__EOF + +remrun usage: + +remrun hostname + +remrun behavior can be changed by setting the following env vars: + NBFAKE_LOG Logfile for remrun output + +__EOF + exit +fi + +export NBFAKE_HOST=$1 +shift +cmd="" +for var in $(env | egrep "^(PARENT_|MT_)"|cut -d= -f1);do + new_var="`echo ${!var}`" + cmd="$cmd export $var=$new_var;" +done +cmd="$cmd $*" +exec nbfake $cmd Index: utils/revtagfsl.scm ================================================================== --- utils/revtagfsl.scm +++ utils/revtagfsl.scm @@ -1,14 +1,23 @@ ;; Copyright 2006-2013, Matthew Welland. ;; -;; This program is made available under the GNU GPL version 2.0 or -;; greater. See the accompanying file COPYING for details. +;; This file is part of Megatest. +;; +;; Megatest is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. +;; +;; Megatest is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. ;; -;; This program is distributed WITHOUT ANY WARRANTY; without even the -;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR -;; PURPOSE. +;; You should have received a copy of the GNU General Public License +;; along with Megatest. If not, see . +;; (use json regex posix) (use srfi-69) ;; Add tags with node nums: trunk(12) ADDED utils/run2mock.scm Index: utils/run2mock.scm ================================================================== --- /dev/null +++ utils/run2mock.scm @@ -0,0 +1,186 @@ +#!/p/foundry/env/pkgs/chicken/4.10.1_v1.63/bin/csi -s +; -*- Mode: Scheme; -*- + +;; Copyright 2006-2017, Matthew Welland. +;; +;; This file is part of Megatest. +;; +;; Megatest is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. +;; +;; Megatest is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with Megatest. If not, see . +;; + +(use ducttape-lib) +(use posix-extras pathname-expand regex matchable) +(use ini-file) +;; plugs a hole in posix-extras in latter chicken versions +(define ##sys#expand-home-path pathname-expand) +(define (realpath x) (resolve-pathname (pathname-expand (or x "/dev/null")) )) + +;; resolve fullpath to this script +(define (get-this-script-fullpath #!key (argv (argv))) + (let* ((this-script + (cond + ((and (> (length argv) 2) + (string-match "^(.*/csi|csi)$" (car argv)) + (string-match "^-(s|ss|sx|script)$" (cadr argv))) + (caddr argv)) + (else (car argv)))) + (fullpath (realpath this-script))) + fullpath)) + +(define *this-script-fullpath* (get-this-script-fullpath)) +(define *this-script-dir* (pathname-directory *this-script-fullpath*)) +(define *this-script-name* (pathname-strip-directory *this-script-fullpath*)) + +(define (false-on-exception thunk) + (handle-exceptions exn #f (thunk) )) + +(define (safe-file-exists? path-string) + (false-on-exception (lambda () (file-exists? path-string)))) + + +(define (crude-config-transformer infile outfile keep-sections-list append-text #!key (filter-patt #f)) + (let* ((inlines (with-input-from-file infile read-lines)) + (keep-lines (let loop ((lines-left inlines) (lines-out '()) (current-section #f) (section-lines-accumulator '())) + (let* ((this-line (if (not (null? lines-left)) + (car lines-left) + "")) + (section-match (string-match "^\\s*\\[([^\\]]+)\\].*" this-line))) + (cond + ((null? lines-left) + (if (member current-section keep-sections-list) + (append lines-out (reverse section-lines-accumulator)) + lines-out)) + (section-match + (let* ((next-lines-left (cdr lines-left)) + (next-lines-out (if (member current-section keep-sections-list) + (append lines-out (reverse section-lines-accumulator)) + lines-out)) + (next-current-section (cadr section-match)) + (next-section-lines-accumulator (list this-line))) + (loop next-lines-left next-lines-out next-current-section next-section-lines-accumulator))) + (else + (let* ((next-lines-left (cdr lines-left)) + (next-lines-out lines-out) + (next-current-section current-section) + (next-section-lines-accumulator + (cond + ((and filter-patt (string-match (conc "^.*"filter-patt".*$") this-line)) + section-lines-accumulator) + (else (cons this-line section-lines-accumulator))))) + (loop next-lines-left next-lines-out next-current-section next-section-lines-accumulator)))))))) + (with-output-to-file outfile (lambda () + (print (string-join keep-lines "\n")) + (print) + (print append-text) + (print))))) + + +(define (testconfig-transformer infile outfile) + (crude-config-transformer + infile + outfile + '("meta" "items" "requirements" "test_meta") + + (conc " + +[ezsteps] +alwayspass /bin/true + +"))) + + + + + +(let* ((mtexe "/p/foundry/env/pkgs/megatest/1.64/31/bin/megatest") + (faux-mtra "/p/fdk/gwa/bjbarcla/issues/mtdev/ch/cap/faux") + (src-mtra "/nfs/pdx/disks/icf_fdk_asic_gwa002/asicfdkqa/fossil/megatestqa/afdkqa") + (target "p1275/5/ADF_r0.7_s/9p27t_tp0") + (run "ww38.4") + (src-mtdb (conc src-mtra "/megatest.db")) + (extra-src-testdirs '("/p/fdk/gwa/asicfdkqa/fossil/ext/afdkqa_ext/trunk/tests")) + (mtconf (with-input-from-pipe (conc "cd "src-mtra" && "mtexe" -show-config -target "target) read)) + (runconf (with-input-from-pipe (conc "cd "src-mtra" && "mtexe" -show-runconfig -dumpmode sexp -target "target) read)) + (testdir-alist (alist-ref "tests-paths" mtconf equal?)) + (testdirs (filter safe-file-exists? + (append extra-src-testdirs + (list (conc src-mtra "/tests")) + (if (and testdir-alist (not (null? testdir-alist))) + (map cadr testdir-alist) + '())))) + (tconfigfiles + (apply append (map (lambda (src-testdir) + (with-input-from-pipe (conc "ls -1 "src-testdir"/*/testconfig") read-lines)) + testdirs))) + (tconf-alist (filter identity + (map (lambda (tcfile) + (let* ((m (string-match "^.*/([^/]+)/testconfig$" tcfile))) + (if (not (null? m)) + (cons (cadr m) tcfile) + #f))) + tconfigfiles)))) + +; (pp mtconf) +; (pp (list 'FOO testdir-alist)) (exit 1) + ;; make megatest area + (when (not (file-exists? src-mtdb)) + (ierr "Source does not exist. Aborting. [src-mtdb]") + (exit 1)) + + (when (file-exists? faux-mtra) + (system (conc "cd "faux-mtra" && rm -rf $(/p/foundry/env/bin/mttmpdir)")) + (system (conc "rm -rf "faux-mtra))) + + (system (conc "mkdir -p "faux-mtra)) + (system (conc "mkdir -p "faux-mtra"/links")) + (system (conc "mkdir -p "faux-mtra"/disk0")) + + (system (conc "cd "src-mtra" && "mtexe" -show-config -target "target" -dumpmode ini > "faux-mtra"/megatest.config.in")) + (crude-config-transformer + (conc faux-mtra"/megatest.config.in") + (conc faux-mtra"/megatest.config") + '("fields" "server" "env-override" "dashboard" "validvalues") + (conc "[setup] +linktree "faux-mtra"/links +max_concurrent_jobs 1000 +launch-delay 5 +use-wal 1 + +" ;; emacs has trouble if a string has [ at the beginning of line, so breaking it up. +"[disks] +disk0 "faux-mtra"/disk0") + filter-patt: "MT_LINKTREE" + ) + + + (system (conc "cd "src-mtra" && "mtexe" -show-runconfig -target "target" -dumpmode ini > "faux-mtra"/runconfigs.config")) + + + (system (conc "mkdir -p "faux-mtra"/tests")) + + (for-each (lambda (tpair) + (pp tpair) + (let* ((testname (car tpair)) + (src-tconfigfile (cdr tpair)) + (destdir (conc faux-mtra"/tests/"testname))) + (do-or-die (conc "mkdir -p "destdir)) + (do-or-die (conc "cp "src-tconfigfile" "destdir"/testconfig.in")) + (testconfig-transformer + (conc destdir"/testconfig.in") + (conc destdir"/testconfig")) + (print "processed test "testname))) + tconf-alist) + + + ) Index: utils/runner ================================================================== --- utils/runner +++ utils/runner @@ -1,7 +1,24 @@ #!/usr/bin/perl -w +# Copyright 2006-2017, Matthew Welland. +# +# This file is part of Megatest. +# +# Megatest is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# Megatest is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with Megatest. If not, see . + $starthr=`date +%k`; $hrsper = 1; $nexthr=$starthr + $hrsper; $ltr='a'; ADDED utils/softlock/Makefile Index: utils/softlock/Makefile ================================================================== --- /dev/null +++ utils/softlock/Makefile @@ -0,0 +1,11 @@ +#Need a chicken 5.1.0 with system-information egg installed in your path + +.DEFAULT : all + +all : softlock + +softlock : softlock.scm + csc -static -L -static -L -lm -L -dl -L -lpthread -L -lcrypto -L -lz softlock.scm + +clean: + rm softlock *.o ADDED utils/softlock/softlock.scm Index: utils/softlock/softlock.scm ================================================================== --- /dev/null +++ utils/softlock/softlock.scm @@ -0,0 +1,135 @@ +;;====================================================================== +;; Copyright 2019, Matthew Welland. +;; +;; This file is part of Megatest. +;; +;; Megatest is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. +;; +;; Megatest is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with Megatest. If not, see . +;; +;;====================================================================== + +(import (chicken string) + (chicken pathname) + system-information + (chicken file posix) + (chicken process-context posix) + (chicken process-context) + (chicken process) + (chicken file posix) + (chicken file) + (chicken time) + srfi-18 +) + + +(if (< (length (command-line-arguments)) 2) ;; require at least lockfile command + (begin + (print "Usage: +softlock lockfile command args ... + +Softlock does weak, transient locking. This is useful to slow down a +deluge of events that can overwhelm hardware or software systems. + +Locks are only good for one second, just enough time to spread events +out. + +On NFS the Unix file locking mechanism works well but lock handling on +the filers can be overwhelmed by many locks occuring quickly. Jobs +that must use NFS file locks can use softlock to minimize the rate +that the file locks are created, preventing the NFS filer from being +swamped. + +Environment variables: + + SOFTLOCK_DEBUG_MODE - if defined enable some messages + +WARNING: the file .softlock will be overwritten and removed by softlock! + +Part of the Megatest project http://www.kiatoa.com/fossils/megatest") + (exit 1))) + +(define (read-lock-file fname) + (handle-exceptions + exn + (begin + (if (get-environment-variable "SOFTLOCK_DEBUG_MODE") + (print "Exception on reading lock file. exn=" exn)) + #f) + (with-input-from-file fname + read-line))) + +(define (lock-file-old fname) + (and (file-exists? fname) + (> (- (current-seconds)(file-modification-time fname)) 1))) ;; hard coded to one second + +(define (check-locked-by-me fname mykey) + (if (file-exists? fname) + (let ((lock-data (read-lock-file fname))) + (if (and lock-data + (equal? mykey lock-data)) + #t + (not (lock-file-old fname)))) ;; if the lockfile is old we are NOT locked. + #f)) + +(define (check-locked-by-someone-else fname mykey) + (if (file-exists? fname) + (let ((lock-data (read-lock-file fname))) + (and lock-data + (not (equal? mykey lock-data)) + (not (lock-file-old fname)))) ;; if the lockfile is old we are NOT locked. + #f)) + +(define (take-lock fname mykey) + (with-output-to-file fname + (lambda () + (print mykey)))) + +(define (run-the-command command params) + (process-wait (process-run command params))) + +(let* ((lockfile (car (command-line-arguments))) + (fulllock (conc lockfile ".softlock")) ;; prevent accidentally removing important files + (lockfdir (pathname-directory lockfile)) + (command (cadr (command-line-arguments))) + (params (cddr (command-line-arguments))) + (mykey (conc (get-host-name) "-" (current-process-id)))) + + ;; sanity checks + (cond + ((not lockfdir) + (print "ERROR: lock file parameter must include path component, e.g. ./mylock") + (exit 1)) + ((not (file-writable? lockfdir)) + (print "ERROR: Can not access directory for lock " lockfdir) + (exit 1)) + ;; add more sanity checks here + ) + + (let loop ((remtries 10)) + (if (> remtries 0) + (if (check-locked-by-someone-else fulllock mykey) + (begin + (print "... lock " fulllock " exists, waiting...") + (thread-sleep! 1.9) + (loop (- remtries 1))) + (begin + (take-lock fulllock mykey) + (if (check-locked-by-me fulllock mykey) + (run-the-command command params) + (begin ;; didn't get the lock + (thread-sleep! (+ 1.9 (/ 1 (+ 1 (random 20))))) ;; add some noise to prevent nyquist problems + (loop (- remtries 1)))))) + (begin + (print "ERROR: not able to get the lock. Gonna take it and proceed...") + (take-lock fulllock mykey) + (run-the-command command params))))) DELETED utils/trace/trace.import.scm Index: utils/trace/trace.import.scm ================================================================== --- utils/trace/trace.import.scm +++ /dev/null @@ -1,32 +0,0 @@ -;;;; trace.import.scm - GENERATED BY CHICKEN 4.9.0.1 -*- Scheme -*- - -(eval '(import - scheme - chicken - csi - advice - extras - ports - data-structures - (except srfi-1 break) - miscmacros)) -(##sys#register-compiled-module - 'trace - (list) - '((breakpoint . trace#breakpoint) - (trace . trace#trace) - (untrace . trace#untrace) - (break . trace#break) - (unbreak . trace#unbreak) - (trace-output-port . trace#trace-output-port) - (continue . trace#continue) - (c . trace#c) - (traced? . trace#traced?) - (trace-module . trace#trace-module) - (untrace-module . trace#untrace-module) - (trace-verbose . trace#trace-verbose) - (trace/untrace . trace#trace/untrace)) - (list) - (list)) - -;; END OF FILE DELETED utils/trace/trace.meta Index: utils/trace/trace.meta ================================================================== --- utils/trace/trace.meta +++ /dev/null @@ -1,10 +0,0 @@ -;;;; trace.meta -*- Scheme -*- - - -((category tools) - (synopsis "tracing and breakpoints") - (author "felix winkelmann") - (license "public domain") - (needs advice ; don't we all? - miscmacros) - (files "tests/run.scm" "trace.meta" "trace.release-info" "trace.scm" "trace.setup") ) DELETED utils/trace/trace.scm Index: utils/trace/trace.scm ================================================================== --- utils/trace/trace.scm +++ /dev/null @@ -1,259 +0,0 @@ -;;;; trace.scm - - -(module trace (breakpoint - trace untrace - break unbreak - trace-output-port - continue c - traced? - trace-module untrace-module - trace-verbose - trace/untrace) - -(import scheme chicken csi) - -(use advice extras ports data-structures) -(require-library srfi-1) -(import (except srfi-1 break) miscmacros) - - -(define *last-breakpoint* #f) -(define *traced-procedures* '()) -(define *broken-procedures* '()) -(define *trace-indent-level* 0) - -(define trace-output-port (make-parameter (current-output-port))) -(define trace-verbose (make-parameter #t)) - -(define (break-entry name args) - ;; Does _not_ unwind! - (##sys#call-with-current-continuation - (lambda (c) - (let ((exn (##sys#make-structure - 'condition - '(exn breakpoint) - (list '(exn . message) "*** breakpoint ***" - '(exn . arguments) (list (cons name args)) - '(exn . location) name - '(exn . continuation) c) ) ) ) - (set! *last-breakpoint* exn) - (signal exn) ) ) ) ) - -(define (break-resume exn) - (let ((a (member '(exn . continuation) (##sys#slot exn 2)))) - (if a - ((cadr a) (void)) - (error "condition has no continuation" exn) ) ) ) - -(define (breakpoint #!optional (name 'breakpoint)) - (break-entry name '()) ) - -(define (trace-indent) - (let ((port (trace-output-port))) - (do ((i (fxmin 3 *trace-indent-level*) (fx- i 1))) - ((fx<= i 0)) - (write-char #\space port) ) - (fprintf port "[~a] " *trace-indent-level*) ) ) - -(define (traced-procedure-entry name args) - (let ((port (trace-output-port))) - (trace-indent) - (set! *trace-indent-level* (fx+ 1 *trace-indent-level*)) - (write (cons name args) port) - (write ", Called from: " port) - (write (conc (car (reverse (get-call-chain))))) - (write-char #\newline port) - (flush-output port) ) ) - -(define (traced-procedure-exit name results) - (let ((port (trace-output-port))) - (set! *trace-indent-level* (fx- *trace-indent-level* 1)) - (trace-indent) - (fprintf port "~a -> " name) - (if results - (for-each - (lambda (x) - (write x port) - (write-char #\space port) ) - results) - (display "(escaping)" port)) - (write-char #\newline port) - (flush-output port) ) ) - -(define (procedure-name proc) - (cond ((procedure-information proc) => - (lambda (info) - (if (pair? info) (car info) info) ) ) - (else ')) ) - -(define (do-trace procs) - (for-each - (lambda (s) - (ensure procedure? s) - (cond ((traced? s) - (warning "procedure already traced" s) ) - (else - (let ((name (procedure-name s))) - (when (trace-verbose) - (fprintf (current-error-port) "; tracing ~a~%" name)) - (set! *traced-procedures* (cons (cons s name) *traced-procedures*)) - (advise - 'around s - (lambda (next args) - (let ((results #f)) - (dynamic-wind - (cut traced-procedure-entry name args) - (lambda () - (call-with-values (cut apply next args) - (lambda rs - (set! results rs) - (apply values rs)))) - (cut traced-procedure-exit name results)))) - '*trace*))))) - procs) ) - -(define (do-untrace-all) - (define (unadvise* p) - (ignore-errors (unadvise p '*trace*))) - (for-each - (lambda (proc) - (let ((proc (car proc))) - (when (trace-verbose) - (fprintf (current-error-port) "; untracing ~a~%" (procedure-name proc)) - (unadvise* proc)))) - *traced-procedures*) - (set! *traced-procedures* '())) - -(define (do-untrace procs) - (for-each - (lambda (s) - (ensure procedure? s) - (let ((p (assq s *traced-procedures*)) - (name (procedure-name s))) - (cond ((not p) (warning "procedure not traced" name)) - (else - (when (trace-verbose) - (fprintf (current-error-port) "; untracing ~a~%" name)) - (ignore-errors (unadvise s '*trace*)) - (set! *traced-procedures* - (delete - p *traced-procedures* - eq?)))))) - procs) ) - -(define (do-break procs) - (for-each - (lambda (s) - (let ((name (procedure-name s))) - (ensure procedure? s) - (cond ((assq s *broken-procedures*) - (warning "procedure already has break-point" name)) - (else - (when (trace-verbose) - (fprintf (current-error-port) "; setting break-point in ~a~%" name)) - (set! *broken-procedures* (cons (cons s name) *broken-procedures*)) - (advise - 'before s - (lambda (args) - (break-entry name args) ) - '*break*) ) ))) - procs) ) - -(define (do-unbreak procs) - (for-each - (lambda (s) - (ensure procedure? s) - (let ((p (assq s *broken-procedures*)) - (name (procedure-name s))) - (cond ((not p) (warning "procedure has no breakpoint" name)) - (else - (when (trace-verbose) - (fprintf (current-error-port) "; removing break-point in ~a~%" name)) - (ignore-errors (unadvise s '*break*)) - (set! *broken-procedures* (delete p *broken-procedures* eq?) ) ) ) ) ) - procs) ) - -(define (do-unbreak-all) - (for-each - (lambda (bp) - (ignore-errors (unadvise (car bp) '*break*))) - *broken-procedures*) - (set! *broken-procedures* '()) - (void)) - -(define (trace . procs) - (cond ((null? procs) - (when (pair? *traced-procedures*) - (printf "Traced:~%~%") - (for-each (lambda (p) (printf " ~a~%" (cdr p))) *traced-procedures*)) ) - (else - (do-trace procs) ) ) ) - -(define (untrace . procs) - (cond ((null? procs) (do-untrace-all)) - (else (do-untrace procs))) - (void)) - -(define (break . procs) - (cond ((null? procs) - (when (pair? *broken-procedures*) - (printf "Breakpoints:~%~%") - (for-each (lambda (p) (printf " ~a~%" (cdr p))) *broken-procedures*)) ) - (else - (do-break procs) ) ) ) - -(define (unbreak . procs) - (cond ((null? procs) (do-unbreak-all)) - (else (do-unbreak procs)))) - -(define (continue #!optional (bp *last-breakpoint*)) - (cond (*last-breakpoint* - (let ((exn *last-breakpoint*)) - (set! *last-breakpoint* #f) - (break-resume exn) ) ) - (else (display "no breakpoint pending\n") ) ) ) - -(define c continue) - -(define (traced? proc) - (assq proc *traced-procedures*)) - -(define (trace/untrace . procs) - (for-each - (lambda (proc) - ((if (traced? proc) do-untrace do-trace) (list proc))) - procs)) - -(define (walk-module mname proc) - (let* ((m (##sys#find-module mname)) - (exps (nth-value 1 (##sys#module-exports m)))) - (for-each - (lambda (exp) - (let* ((realname (cdr exp)) - (prim (get realname '##core#primitive))) - (if prim - (warning "export is a core-library primitive - not traced" (car exp)) - (when (##sys#symbol-has-toplevel-binding? realname) - (let ((val (##sys#slot realname 0))) - (when (procedure? val) - (proc val))))))) - exps))) - -(define (trace-module . mnames) - (for-each - (lambda (mname) - (walk-module mname trace)) - mnames)) - -(define (untrace-module . mnames) - (for-each - (lambda (mname) - (walk-module - mname - (lambda (proc) - (when (traced? proc) - (do-untrace (list proc)))))) - mnames)) - -) DELETED utils/trace/trace.setup Index: utils/trace/trace.setup ================================================================== --- utils/trace/trace.setup +++ /dev/null @@ -1,9 +0,0 @@ -;;;; trace.setup -*- Scheme -*- - - -(compile -s trace.scm -O3 -d1 -j trace) -(compile -s trace.import.scm -O3 -d0) - -(install-extension - 'trace - '("trace.so" "trace.import.so")) ADDED utils/triage.rb Index: utils/triage.rb ================================================================== --- /dev/null +++ utils/triage.rb @@ -0,0 +1,96 @@ +#!/usr/bin/env ruby + +# Copyright 2006-2017, Matthew Welland. +# +# This file is part of Megatest. +# +# Megatest is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# Megatest is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with Megatest. If not, see . + +#dir = "." +#if ARGV.length == 1 +# dir = ARGV[0] +#end +#puts dir +#exit 1 + +allfiles = [] +server_logs = `find logs/ -type f -name 'server*.log' 2>/dev/null`.split /\n/ +allfiles += server_logs +ARGV.each{|dir| + nbfiles = `find #{dir} -type f -name '##*' 2>/dev/null`.split /\n/ + fakefiles = `find #{dir} -type f -name 'NBFAKE-*' 2>/dev/null`.split /\n/ + allfiles = allfiles + nbfiles + fakefiles +} + +buckets = Hash.new{|h,k| h[k]=[]} +#;buckets['OK'] = [] +#;buckets['stackdump'] = [] + + +sig_patterns = [ + 'cannot create directory - File exists', + 'in thread: \(finalize!\) bad argument type - not a database or statement: #', + 'cannot delete file - No such file or directory: .*\/.runconfig.', + 'Error: \(hash-table-ref/default\) bad argument type - not a structure of the required type', + '\(#\): in thread: \(open-output-file\) cannot open file - File exists:', + 'http-transport.scm:442: posix-extras#change-file-times', + 'thread: \(file-exists\?\) system error while trying to access file:', + 'error: database is locked', + 'Finalizing failed, unable to close due to unfinalized statements or unfinished backups', + 'rmt.scm:276: current-milliseconds', + 'http-transport.scm:366: exit', + 'should never happen', + 'FATAL: \*configdat\* was inaccessible! This should never happen.', + 'FATAL ERROR: http-transport:client-api-send-receive called with no server info', + '!!ISOENV PRESENT!!' + + ] + +allfiles.each{|logfile| + bucket = 'OK' + open(logfile){|fh| + fh.each{|line| + + if line.match(/Call history/) + if bucket == 'OK' + bucket='??' + end + end + sig_patterns.each_with_index{|pat,bucket_name| + #bucket_name,pat = i + if line.match(/#{pat}/) + bucket=bucket_name + end + } + + } + } + buckets[bucket] << logfile +} + +puts "count\tsignature\texample file" +buckets.keys.each{|bucket| + count = buckets[bucket].length + + example = buckets[bucket][0] + if example + puts "#{count}\tsignature-#{bucket}\t#{example}" + if bucket.to_s.match(/^[0-9]+$/) + puts " `- pattern = /#{sig_patterns[bucket]}/" + end + else + puts "#{count}\tsignature-#{bucket}" + end +} +#puts buckets['stackdump'][0] ADDED utils/unlock_db.sh Index: utils/unlock_db.sh ================================================================== --- /dev/null +++ utils/unlock_db.sh @@ -0,0 +1,44 @@ +#!/bin/bash + +# Copyright 2006-2017, Matthew Welland. +# +# This file is part of Megatest. +# +# Megatest is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# Megatest is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with Megatest. If not, see . + +## Enh : +# 1. if /tmp/repo exists, delte it or name it something else +# 2. compare the repo is successfully created + +## Usage : +# unlock_db.sh + +function unlock_db () { + repo=$1 + echo $repo + ls -lrt $repo + cp $repo /tmp/${USER}_repo.tmp + ls -lrt /tmp/${USER}_repo.tmp + ## Eventually compare the sizes of 2 repos + cmd=$(rm -r $repo && sqlite3 /tmp/${USER}_repo.tmp .dump | sqlite3 $repo) + echo $cmd + ls -lrt $repo + chmod g+w $repo +} + +#====================================================================== +# T H E M A I N H A N D L E R A N D P R O C E S S I N G +#====================================================================== + +unlock_db $1 ADDED utils/viewscreen Index: utils/viewscreen ================================================================== --- /dev/null +++ utils/viewscreen @@ -0,0 +1,36 @@ +#!/bin/bash + +# Copyright 2006-2017, Matthew Welland. +# +# This file is part of Megatest. +# +# Megatest is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# Megatest is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with Megatest. If not, see . + +if ! type screen &> /dev/null;then + xterm -geometry 180x20 -e "$*;echo Press any key to continue;bash -c 'read -n 1 -s'" & + exit +fi + +if [[ $(screen -list | egrep 'Attached|Detached'|awk '{print $1}') == "" ]];then + # echo "No screen found for displaying to. Run \"screen\" in an xterm" + # exit 1 + xterm -e screen -e^ff & + sleep 1 + screen -X hardstatus off + screen -X hardstatus alwayslastline + screen -X hardstatus string '%{= kG}[ %{G}%H %{g}][%= %{= kw}%?%-Lw%?%{r}(%{W}%n*%f%t%?(%u)%?%{r})%{w}%?%+Lw%?%?%= %{g}][%{B} %m-%d %{W} %c %{g}]' +fi + +cmd="cd $PWD;$*" +screen -X screen bash -c "$cmd;echo \"Press any key to continue, ctrl-f to see other windows\";bash -c 'read -n 1 -s'" & ADDED utils/watch-close-wait.sh Index: utils/watch-close-wait.sh ================================================================== --- /dev/null +++ utils/watch-close-wait.sh @@ -0,0 +1,25 @@ +# Copyright 2006-2017, Matthew Welland. +# +# This file is part of Megatest. +# +# Megatest is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# Megatest is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with Megatest. If not, see . + +psline=$(ps -F -u $USER | grep "mtest" |grep " -run " | egrep " -(target|reqtarg) "| head -1) +id=$(echo $psline|awk '{print $2}') +echo "Watching process for command line: $psline" +echo " with PID=$id" +while true;do + echo "CLOSE_WAIT: $(lsof -n | grep CLOSE_WAIT | grep $id | wc -l) ALL OPEN: $(lsof -n |grep $id|wc -l) ALL CLOSE_WAIT: $(netstat -ap 2> /dev/null| grep -i close_wait| wc -l)" + sleep 1 +done ADDED utils/whodunit.scm Index: utils/whodunit.scm ================================================================== --- /dev/null +++ utils/whodunit.scm @@ -0,0 +1,87 @@ +;; Copyright 2006-2017, Matthew Welland. +;; +;; This file is part of Megatest. +;; +;; Megatest is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. +;; +;; Megatest is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with Megatest. If not, see . +;; +(module whodunit + + * + + +(import + (chicken process-context) + (chicken process) + (chicken string) + (chicken base) + (chicken sort) + (chicken io) + srfi-69 + scheme +) + +(define *numsamples* (or (and (> (length (argv)) 1) + (string->number (cadr (argv)))) + 3)) + +(define (topdata) + (with-input-from-pipe + (conc "top -b -n " *numsamples* " -d 0.1") + read-lines)) + +(define (cleanup-data topdat) + (let loop ((hed (car topdat)) + (tal (cdr topdat)) + (res '())) + (let* ((line-list (string-split hed)) + (nums (map (lambda (indat)(or (string->number indat) indat)) line-list)) + (not-data (or (null? nums) + (not (number? (car nums))))) + (new-res (if not-data res (cons nums res)))) + (if (null? tal) + new-res + (loop (car tal)(cdr tal) new-res))))) + + +;; sum up +(define (sum-up data ht) + (for-each + (lambda (indat) + (let ((pid (car indat)) + (usr (cadr indat)) + (cpu (list-ref indat 8))) + (hash-table-set! ht usr (+ cpu (hash-table-ref/default ht usr 0))))) + data)) + +(define (print-results userhash) + (for-each + (lambda (usr) + (let* ((usage (inexact->exact (round (/ (hash-table-ref userhash usr) *numsamples*))))) + (if (> usage 0) + (print usr (if (< (string-length usr) 8) "\t\t" "\t") usage)))) + (sort (hash-table-keys userhash) + (lambda (a b) + (> (hash-table-ref userhash a) + (hash-table-ref userhash b)))))) + +) +(import whodunit srfi-69 (chicken sort)) + +(print "Getting " *numsamples* " samples of cpu usage data.") +(define data (cleanup-data (topdata))) +(define pidhash (make-hash-table)) +(define userhash (make-hash-table)) +(sum-up data userhash) + +(print-results userhash) Index: vg-test.scm ================================================================== --- vg-test.scm +++ vg-test.scm @@ -1,5 +1,22 @@ +;; Copyright 2006-2017, Matthew Welland. +;; +;; This file is part of Megatest. +;; +;; Megatest is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. +;; +;; Megatest is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with Megatest. If not, see . +;; (use canvas-draw iup foof-loop) (import canvas-draw-iup) (load "vg.scm") Index: vg.scm ================================================================== --- vg.scm +++ vg.scm @@ -1,14 +1,22 @@ ;; ;; Copyright 2016 Matthew Welland. ;; -;; This program is made available under the GNU GPL version 2.0 or -;; greater. See the accompanying file COPYING for details. +;; This file is part of Megatest. +;; +;; Megatest is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. +;; +;; Megatest is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. ;; -;; This program is distributed WITHOUT ANY WARRANTY; without even the -;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR -;; PURPOSE. +;; You should have received a copy of the GNU General Public License +;; along with Megatest. If not, see . ;; strftime('%m/%d/%Y %H:%M:%S','now','localtime') (use typed-records srfi-1) @@ -368,15 +376,23 @@ (arithmetic-shift a 24) (arithmetic-shift r 16) (arithmetic-shift g 8) b)) +;; Obsolete function +;; (define (vg:generate-color) (vg:rgb->number (random 255) (random 255) (random 255))) - ;;(vg:rgb->number 0 0 0)) + +;; Need to return a string of random iup-color for graph +;; +(define (vg:generate-color-rgb) + (conc (number->string (random 255)) " " + (number->string (random 255)) " " + (number->string (random 255)))) (define (vg:iup-color->number iup-color) (apply vg:rgb->number (map string->number (string-split iup-color)))) ;;====================================================================== @@ -547,11 +563,11 @@ ;; (begin ;; (canvas-foreground-set! cnv fill-color) ;; (canvas-box! cnv llx ulx lly uly))) ;; docs are all over the place on this one.;; w h) (if line-color (canvas-foreground-set! cnv line-color) - (if fill-color + #;(if fill-color (canvas-foreground-set! cnv prev-foreground-color))) (canvas-line! cnv llx ulx lly uly) (canvas-foreground-set! cnv prev-foreground-color) (if text (let* ((prev-font (canvas-font cnv)) Index: vg_records.scm ================================================================== --- vg_records.scm +++ vg_records.scm @@ -1,7 +1,25 @@ ;; Created by records.sh. DO NOT EDIT THIS FILE. Edit records.sh instead ;; Generated using make-vector-record -safe vg lib comps + +;; Copyright 2006-2017, Matthew Welland. +;; +;; This file is part of Megatest. +;; +;; Megatest is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. +;; +;; Megatest is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with Megatest. If not, see . +;; (use simple-exceptions) (define vg:lib-exn (make-exception "wrong record type, expected vg:lib." 'assert)) (define (pmake-vg:lib . params)(let ((v (if (null? params)(make-vector 2)(apply vector 'vg:lib params)))) v)) (define (make-vg:lib #!key Index: widgets.scm ================================================================== --- widgets.scm +++ widgets.scm @@ -1,5 +1,22 @@ +;; Copyright 2006-2017, Matthew Welland. +;; +;; This file is part of Megatest. +;; +;; Megatest is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. +;; +;; Megatest is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with Megatest. If not, see . + (require-library srfi-4 iup) (import srfi-4 iup iup-pplot iup-glcanvas) ;; iup-web (define (popup dlg . args) (apply show dlg #:modal? 'yes args) ADDED wrappers/cfg.sh Index: wrappers/cfg.sh ================================================================== --- /dev/null +++ wrappers/cfg.sh @@ -0,0 +1,27 @@ +# Copyright 2006-2017, Matthew Welland. +# +# This file is part of Megatest. +# +# Megatest is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# Megatest is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with Megatest. If not, see . + +if [ -z $MT_ORIG_ENV ]; then + export MT_ORIG_ENV=$( PREFIX/bin/serialize-env ) +fi + +if [ "$LD_LIBRARY_PATH" != "" ];then + export LD_LIBRARY_PATH=PREFIX:PREFIX/lib:PREFIX/lib64:$LD_LIBRARY_PATH +else + export LD_LIBRARY_PATH=PREFIX:PREFIX/lib:PREFIX/lib64 +fi + ADDED wrappers/dashboard Index: wrappers/dashboard ================================================================== --- /dev/null +++ wrappers/dashboard @@ -0,0 +1,49 @@ +#!/bin/bash + +# Copyright 2006-2017, Matthew Welland. +# +# This file is part of Megatest. +# +# Megatest is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# Megatest is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with Megatest. If not, see . + +# # disable if not running on homehost +# if [[ -e .homehost ]]; then +# homehostname=$( host `cat .homehost` | awk '{print $NF}' | sed 's/\.$//' ) +# hostname=$( hostname -f ) +# +# if [[ ! ($homehostname == $hostname) ]]; then +# echo "ERROR: this host ($hostname) is not the homehost ($homehostname) for this megatest run area. Cannot start dashboard." +# echo " Please log into homehost before launching dashboard." +# exit 1 +# fi +# fi + +# check that $DISPLAY is set +if [[ -z $DISPLAY ]]; then + echo 'ERROR: $DISPLAY environment variable is not set; megatest dashboard requires X display address to be set in $DISPLAY.' + exit 1 +fi + +# check that $DISPLAY is proper +if [[ -x $(which xdpyinfo 2>/dev/null) ]]; then + if ! xdpyinfo -display "$DISPLAY" &>/dev/null; then + echo 'ERROR: megatest dashboard cannot open display "'$DISPLAY'". Please check $DISPLAY environment variable.' + exit 1 + fi +fi +if [[ $(ulimit -a | grep 'open files' | awk '{print $4}') -gt 10000 ]];then ulimit -n 10000;fi +lsbr=$(lsb_release -sr) +source PREFIX/ARCHSTR/cfg.sh +exec PREFIX/dboard "$@" + ADDED wrappers/megatest Index: wrappers/megatest ================================================================== --- /dev/null +++ wrappers/megatest @@ -0,0 +1,24 @@ +#!/bin/bash + +# Copyright 2006-2017, Matthew Welland. +# +# This file is part of Megatest. +# +# Megatest is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# Megatest is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with Megatest. If not, see . + +if [[ $(ulimit -a | grep 'open files' | awk '{print $4}') -gt 20000 ]];then ulimit -n 20000;fi +lsbr=$(lsb_release -sr) +source PREFIX/ARCHSTR/cfg.sh +exec PREFIX/mtest "$@" +