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: .mtutil.scm ================================================================== --- .mtutil.scm +++ .mtutil.scm @@ -23,45 +23,46 @@ (define (str-first-char->number str) (char->integer (string-ref str 0))) ;; example of how to set up and write target mappers ;; -(hash-table-set! *target-mappers* - 'prefix-contour - (lambda (target run-name area area-path reason contour mode-patt) - (conc contour "/" target))) -(hash-table-set! *target-mappers* - 'prefix-area-contour - (lambda (target run-name area area-path reason contour mode-patt) - (conc area "/" contour "/" target))) - -(hash-table-set! *runname-mappers* - '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)))) - -(hash-table-set! *runname-mappers* - 'auto - (lambda (target run-name area area-path reason contour mode-patt) - "auto-eh")) - -;; (print "Got here!") +(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 +. Index: Makefile ================================================================== --- Makefile +++ Makefile @@ -1,31 +1,55 @@ +# 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= 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 filedb.scm \ - client.scm synchash.scm daemon.scm mt.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 tdb.scm rpc-transport.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 +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)) + +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}') @@ -33,37 +57,77 @@ 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") PNGFILES = $(shell cd docs/manual;ls *png) -all : $(PREFIX)/bin/.$(ARCHSTR) mtest dboard mtut ndboard +#all : $(PREFIX)/bin/.$(ARCHSTR) mtest dboard mtut ndboard +all : $(PREFIX)/bin/.$(ARCHSTR) mtest dboard mtut -mtest: $(OFILES) readline-fix.scm megatest.o - csc $(CSCOPTS) $(OFILES) megatest.o -o mtest +mtest: $(OFILES) readline-fix.scm megatest.o $(MOFILES) mofiles/ftail.o + csc $(CSCOPTS) $(OFILES) $(MOFILES) megatest.o -o mtest -dboard : $(OFILES) $(GOFILES) dashboard.scm - csc $(CSCOPTS) $(OFILES) dashboard.scm $(GOFILES) -o dboard +dboard : $(OFILES) $(GOFILES) dashboard.scm $(MOFILES) + csc $(CSCOPTS) $(OFILES) dashboard.scm $(GOFILES) $(MOFILES) -o dboard ndboard : newdashboard.scm $(OFILES) $(GOFILES) csc $(CSCOPTS) $(OFILES) $(GOFILES) newdashboard.scm -o ndboard -mtut: $(OFILES) mtut.scm +mtut: $(OFILES) megatest-fossil-hash.scm mtut.scm csc $(CSCOPTS) $(OFILES) mtut.scm -o mtut +TCMTOBJS = \ + api.o \ + archive.o \ + cgisetup/models/pgdb.o \ + client.o \ + common.o \ + configf.o \ + daemon.o \ + db.o \ + env.o \ + http-transport.o \ + items.o \ + keys.o \ + launch.o \ + lock-queue.o \ + margs.o \ + mt.o \ + megatest-version.o \ + ods.o \ + portlogger.o \ + process.o \ + rmt.o \ + rpc-transport.o \ + runconfig.o \ + runs.o \ + server.o \ + tasks.o \ + tdb.o \ + tests.o \ + subrun.o \ + + +tcmt : $(TCMTOBJS) tcmt.scm + csc $(CSCOPTS) $(TCMTOBJS) 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 +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) @@ -72,18 +136,18 @@ # # $(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 \ +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 -tests.o runs.o dashboard.o dashboard-tests.o dashboard-main.o : run_records.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 -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 rpc-transport.scm +rmt.scm client.scm common.scm configf.scm dashboard-guimonitor.scm dashboard-tests.scm dashboard-context-menu.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 @@ -111,13 +175,23 @@ chmod a+x $(PREFIX)/bin/newdashboard $(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 + +$(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/.$(ARCHSTR)/mdboard : multi-dboard # $(INSTALL) multi-dboard $(PREFIX)/bin/.$(ARCHSTR)/mdboard # $(PREFIX)/bin/mdboard : $(PREFIX)/bin/.$(ARCHSTR)/mdboard utils/mk_wrapper @@ -192,12 +266,17 @@ $(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)/share/db/mt-pg.sql $(PREFIX)/bin/.$(ARCHSTR)/ndboard $(PREFIX)/bin/newdashboard + $(PREFIX)/bin/tcmt $(PREFIX)/share/db/mt-pg.sql \ + js +# $(PREFIX)/bin/.$(ARCHSTR)/ndboard + +# $(PREFIX)/bin/newdashboard $(PREFIX)/bin/.$(ARCHSTR) : mkdir -p $(PREFIX)/bin/.$(ARCHSTR) mkdir -p $(PREFIX)/bin/.$(ARCHSTR)/lib @@ -272,15 +351,23 @@ 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 + +datashare-testing/sauthorize : sretrieve.scm megatest-version.o margs.o configf.o process.o common.o + csc sauthorize.scm megatest-version.o margs.o configf.o process.o common.o -o datashare-testing/sauthorize + + +datashare-testing/sauthorize : sretrieve.scm megatest-version.o margs.o configf.o process.o common.o + csc sauthorize.scm megatest-version.o margs.o configf.o process.o common.o -o datashare-testing/sauthorize + 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 + srfi-1 posix regex regex-case srfi-69 # base64 dot-locking \ # csv-xml z3 # "(define (toplevel-command . a) #f)" @@ -301,8 +388,25 @@ 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 +portlogger-example : portlogger-example.scm api.o archive.o client.o common.o configf.o daemon.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 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 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 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 + +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"' Index: Makefile.deploy ================================================================== --- Makefile.deploy +++ Makefile.deploy @@ -1,29 +1,58 @@ # make install CSCOPTS='-accumulate-profile -profile-name $(PWD)/profile-ww$(shell date +%V.%u)' + +# 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 \ - client.scm synchash.scm daemon.scm mt.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 tdb.scm rpc-transport.scm \ - portlogger.scm archive.scm env.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=crypt matchable readline apropos base64 regex-literals format regex-case test coops trace csv \ +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}') @@ -42,31 +71,46 @@ IMVER=3.11 IUPVER=3.17 KTYPE=26g4 CDVER=5.10 -all : $(PREFIX)/bin/.$(ARCHSTR) mtest dboard eggs sqlite matt iup +all : $(PREFIX)/bin/.$(ARCHSTR) postgres nanomsg mtest dboard mtut eggs sqlite matt iup wrappers -mtest: $(OFILES) readline-fix.scm megatest.o +mtest: $(OFILES) readline-fix.scm megatest.o $(MOFILES) mofiles/ftail.o mkdir -p $(PREFIX)/deploy - csc $(CSCOPTS) $(OFILES) megatest.o -o $(PREFIX)/deploy/mtest + 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 md5 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 z3 sql-de-lite hostinfo rpc directory-utils md5 spiffy http-client spiffy-request-vars spiffy-directory-listing posix-extras call-with-environment-variables rpc fmt + 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=`realpath $(PREFIX)/deploy/mtest` + 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 + 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' @@ -82,10 +126,39 @@ 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 @@ -95,31 +168,42 @@ 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=`realpath $(PREFIX)/deploy/mtest/` --enable-shared + cd ffcall && ./configure --prefix=$(PREFIX)/deploy/mtest/ --enable-shared cd ffcall && make CC="gcc -fPIC" cd ffcall && make install - CSC_OPTIONS="-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)/deploy/mtest/include -L$(PREFIX)/deploy/mtest" chicken-install -deploy -p $(PREFIX)/deploy/mtest -D no-library-checks canvas-draw + 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 - csc $(CSCOPTS) $(OFILES) dashboard.scm $(GOFILES) -o $(PREFIX)/deploy/mtest/dboard2 +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 @@ -155,10 +239,20 @@ 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 + $(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 $(PREFIX)/bin/newdashboard : $(PREFIX)/bin/.$(ARCHSTR)/ndboard utils/mk_wrapper utils/mk_wrapper $(PREFIX) ndboard $(PREFIX)/bin/newdashboard chmod a+x $(PREFIX)/bin/newdashboard @@ -203,10 +297,15 @@ $(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 @@ -226,16 +325,21 @@ 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/.$(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) @@ -262,19 +366,21 @@ $(DEPLOYHELPERS) : utils/mt_* $(INSTALL) $< $@ chmod a+X $@ deploytarg/apropos.so : Makefile - chicken-install -p deploytarg -deploy -keep-installed $(EGGS) - + 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/viewsceen deploytarg/nbfind deploytarg/apropos.so +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 @@ -331,11 +437,24 @@ 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 +# 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: README ================================================================== --- README +++ README @@ -1,9 +1,9 @@ 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: api.scm ================================================================== --- api.scm +++ api.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 srfi-69 posix) (declare (unit api)) @@ -23,10 +32,12 @@ 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 @@ -39,32 +50,39 @@ get-prereqs-not-met get-count-tests-running-for-run-id get-run-info get-run-status get-run-stats + get-run-times get-targets get-target ;; register-run get-tests-tags + get-test-times get-tests-for-run 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 + get-changed-record-ids )) (define api:write-queries '( get-keys-write ;; dummy "write" query to force server start @@ -126,10 +144,11 @@ (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 (vector-ref dat 0)) (cmd (if (symbol? cmd-in) cmd-in @@ -152,11 +171,26 @@ ;; 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)) + + ;;((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)) @@ -193,10 +227,16 @@ ;; 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)) + ;; 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)) @@ -232,35 +272,43 @@ ((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)) + ((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)) ((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-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)) 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 @@ -137,11 +145,11 @@ (> (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 @@ -152,11 +160,11 @@ #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)) + ((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 0 *default-log-port* "From test-dat=" test-dat " derived the following:\n" "test-partial-path = " test-partial-path "\n" @@ -180,13 +188,13 @@ (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)) + (if (not (common:file-exists? archive-dir)) (create-directory archive-dir #t)) - (if (not (file-exists? (conc archive-dir "/HEAD"))) + (if (not (common: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) @@ -233,11 +241,11 @@ (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)) ;; 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)) @@ -250,11 +258,11 @@ ;; 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))) 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) -;; Index: cgisetup/models/pgdb.scm ================================================================== --- cgisetup/models/pgdb.scm +++ cgisetup/models/pgdb.scm @@ -90,48 +90,141 @@ (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: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))) + ;;====================================================================== ;; 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) - (dbi:get-one dbh "SELECT id FROM runs WHERE ttype_id=? AND target=? AND run_name=?;" - spec-id target run-name)) +(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 run-id return all the run info ;; -(define (pgdb:get-run-info dbh run-id) ;; to join ttype or not? +(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)) + 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) +(define (pgdb:refresh-run-info dbh run-id state status owner event-time comment fail-count pass-count area-id) ;; area-id) (dbi:exec dbh "UPDATE runs SET - state=?,status=?,owner=?,event_time=?,comment=?,fail_count=?,pass_count=? - WHERE id=?;" - state status owner event-time comment fail-count pass-count run-id)) + state=?,status=?,owner=?,event_time=?,comment=?,fail_count=?,pass_count=? + WHERE id=? and area_id=?;" + state status owner event-time comment fail-count pass-count 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) +(define (pgdb:insert-run dbh ttype-id target run-name state status owner event-time comment fail-count pass-count area-id) + (dbi:exec + dbh + "INSERT INTO runs (ttype_id,target,run_name,state,status,owner,event_time,comment,fail_count,pass_count,area_id ) + VALUES (?,?,?,?,?,?,?,?,?,?,?);" + ttype-id target run-name state status owner event-time comment fail-count pass-count area-id)) + +;;====================================================================== +;; 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:insert-test-step dbh test-id stepname state status event_time comment logfile) + (dbi:exec + dbh + "INSERT INTO test_steps (test_id,stepname,state,status,event_time,logfile,comment) + VALUES (?,?,?,?,?,?,?);" + test-id stepname state status event_time logfile comment)) + +(define (pgdb:update-test-step dbh step-id test-id stepname state status event_time comment logfile) + (dbi:exec + dbh + "UPDATE test_steps SET + test_id=?,stepname=?,state=?,status=?,event_time=?,logfile=?,comment=? + WHERE id=?;" + test-id stepname state status event_time logfile comment 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:insert-test-data dbh test-id category variable value expected tol units comment status type) + ; (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) + VALUES (?,?,?,?,?,?,?,?,?,?);" + test-id category variable value expected tol units comment status type)) + +(define (pgdb:update-test-data dbh data-id test-id category variable value expected tol units comment status type) (dbi:exec - dbh - "INSERT INTO runs (ttype_id,target,run_name,state,status,owner,event_time,comment,fail_count,pass_count) - VALUES (?,?,?,?,?,?,?,?,?,?);" - ttype-id target run-name state status owner event-time comment fail-count pass-count)) + dbh + "UPDATE test_data SET + test_id=?, category=?, variable=?, value=?, expected=?, tol=?, units=?, comment=?, status=?, type=? + WHERE id=?;" + test-id category variable value expected tol units comment status type data-id )) + + ;;====================================================================== ;; T E S T S ;;====================================================================== Index: client.scm ================================================================== --- client.scm +++ client.scm @@ -10,18 +10,13 @@ ;;====================================================================== ;; C L I E N T S ;;====================================================================== -(require-extension (srfi 18) extras tcp s11n) - -(use srfi-1 posix regex regex-case srfi-69 hostinfo md5 message-digest matchable) -;; (use zmq) - -(use (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)) ADDED codescanlib.scm Index: codescanlib.scm ================================================================== --- /dev/null +++ codescanlib.scm @@ -0,0 +1,142 @@ +;; 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 @@ -7,23 +7,23 @@ ;; This program is distributed WITHOUT ANY WARRANTY; without even the ;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR ;; PURPOSE. ;;====================================================================== -(use srfi-1 posix regex-case base64 format dot-locking csv-xml z3 sql-de-lite hostinfo md5 message-digest typed-records directory-utils stack - matchable) -(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 ;; 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 keys)) (include "common_records.scm") + ;; (require-library margs) ;; (include "margs.scm") ;; (define old-exit exit) @@ -31,10 +31,27 @@ ;; (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) + (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 (substring-index ":" key) ;; variables containing : are for internal use and cannot be environment variables. (debug:print-error 4 *default-log-port* "skip setting internal use only variables containing \":\"") (if (and (string? val) @@ -46,11 +63,21 @@ (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))) @@ -76,10 +103,11 @@ ;; (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) @@ -90,10 +118,11 @@ (define *passnum* 0) ;; when running track calls to run-tests or similar ;; (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) ;; 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 > @@ -111,18 +140,20 @@ (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) ;; override with [server] transport http|rpc|nmsg (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 *server-id* #f) +(define *server-id* #f) (define *server-info* #f) ;; good candidate for easily convert to non-global (define *time-to-exit* #f) (define *server-run* #t) (define *run-id* #f) (define *server-kind-run* (make-hash-table)) @@ -129,10 +160,11 @@ (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 @@ -148,18 +180,57 @@ (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 *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)) + +;; 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*)) + + + + + (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:get-timeout)) ;; default from server:get-timeout + (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 @@ -225,28 +296,40 @@ (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)))) + ;; Move me elsewhere ... ;; RADT => Why do we meed the version check here, this is called only if version misma ;; -(define (common:cleanup-db dbstruct) - (db:multi-db-sync +(define (common:cleanup-db dbstruct #!key (full #f)) + (apply db:multi-db-sync dbstruct + 'schema ;; 'new2old 'killservers - 'dejunk - ;; 'adj-testids + 'adj-target ;; 'old2new 'new2old - 'schema) - (if (common:version-changed?) + ;; (if full + '(dejunk) + ;; '()) + ) + (if (common:api-changed?) (common:set-last-run-version))) ;; Rotate logs, logic: ;; if > 500k and older than 1 week: ;; remove previous compressed log and compress this log @@ -266,11 +349,11 @@ (> (file-size fullname) 200000)) (and (string-match "^server-.*.log" file) (> (- (current-seconds) (file-modification-time fullname)) (* 8 60 60)))) (let ((gzfile (conc fullname ".gz"))) - (if (file-exists? gzfile) + (if (common:file-exists? gzfile) (begin (debug:print-info 0 *default-log-port* "removing " gzfile) (delete-file gzfile))) (debug:print-info 0 *default-log-port* "compressing " file) (system (conc "gzip " fullname))) @@ -285,22 +368,22 @@ ;; 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:on-homehost?) - (if (common:version-changed?) + (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))) + (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 (file-exists? mtconf) (file-exists? dbfile) (not read-only) + ((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 @@ -307,14 +390,14 @@ (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 dbstruct))) - ((not (file-exists? mtconf)) + ((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 (file-exists? dbfile)) + ((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)) @@ -321,14 +404,14 @@ (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)))) + (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 ;;====================================================================== @@ -390,10 +473,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))) @@ -424,11 +510,11 @@ ;; (define (common:simple-file-lock fname #!key (expire-time 300)) (handle-exceptions exn #f ;; don't really care what went wrong right now. NOTE: I have not seen this one actually fail. - (if (file-exists? fname) + (if (common: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) @@ -435,11 +521,11 @@ (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) + (if (common:file-exists? fname) (with-input-from-file fname (lambda () (equal? key-string (read-line)))) #f))))) @@ -462,12 +548,14 @@ ;;====================================================================== ;; S T A T E S A N D S T A T U S E S ;;====================================================================== -(define *common:std-states* - '((0 "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") @@ -474,36 +562,59 @@ (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 "DELETED") + '(;; (0 "DELETED") (1 "n/a") (2 "PASS") - (3 "CHECK") - (4 "SKIP") - (5 "WARN") - (6 "WAIVED") + (3 "SKIP") + (4 "WARN") + (5 "WAIVED") + (6 "CHECK") (7 "STUCK/DEAD") - (8 "FAIL") - (9 "ABORT"))) + (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")) + '("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")) + '("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 @@ -588,20 +699,26 @@ (pathname-file *toppath*) #f))) ;; (pathname-file (current-directory))))) (define common:get-area-name common:get-testsuite-name) -(define (common:get-db-tmp-area) +(define (common:get-db-tmp-area . junk) (if *db-cache-path* *db-cache-path* - (if *toppath* - (let ((dbpath (create-directory (conc "/tmp/" (current-user-name) - "/megatest_localdb/" - (common:get-testsuite-name) "/" - (string-translate *toppath* "/" ".")) #t))) - (set! *db-cache-path* dbpath) - dbpath) + (if *toppath* ;; common:get-create-writeable-dir + (handle-exceptions + exn + (begin + (debug:print-error 0 *default-log-port* "Couldn't create path to " dbdir) + (exit 1)) + (let ((dbpath (common:get-create-writeable-dir + (list (conc "/tmp/" (current-user-name) + "/megatest_localdb/" + (common:get-testsuite-name) "/" + (string-translate *toppath* "/" ".")))))) ;; #t)))) + (set! *db-cache-path* dbpath) + dbpath)) #f))) (define (common:get-area-path-signature) (message-digest-string (md5-primitive) *toppath*)) @@ -618,23 +735,10 @@ ;; (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) - -;;;; run-ids -;; if #f use *db-local-sync* : or 'local-sync-flags -;; if #t use timestamps : or 'timestamps -(define (common:sync-to-megatest.db dbstruct) - (let ((start-time (current-seconds)) - (res (db:multi-db-sync dbstruct 'new2old))) - (let ((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") - (debug:print-info 0 *default-log-port* "Sync of newdb to olddb completed in " sync-time " seconds pid="(current-process-id)))) - res)) - (define *wdnum* 0) (define *wdnum*mutex (make-mutex)) @@ -661,102 +765,34 @@ (< 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) - (let ((res (db:multi-db-sync dbstruct 'old2new))) - (debug:print-info 13 *default-log-port* "rosync called, " res " records transferred."))) + (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))) - - -(define (common:writable-watchdog dbstruct) - (thread-sleep! 0.05) ;; delay for startup - (let ((legacy-sync (common:run-sync?)) - (debug-mode (debug:debug-mode 1)) - (last-time (current-seconds)) - (this-wd-num (begin (mutex-lock! *wdnum*mutex) (let ((x *wdnum*)) (set! *wdnum* (add1 *wdnum*)) (mutex-unlock! *wdnum*mutex) x)))) - (debug:print-info 2 *default-log-port* "Periodic sync thread started.") - (debug:print-info 3 *default-log-port* "watchdog starting. legacy-sync is " legacy-sync" pid="(current-process-id)" this-wd-num="this-wd-num) - (if (and legacy-sync (not *time-to-exit*)) - (let* (;;(dbstruct (db:setup)) - (mtdb (dbr:dbstruct-mtdb dbstruct)) - (mtpath (db:dbdat-get-path mtdb))) - (debug:print-info 0 *default-log-port* "Server running, periodic sync started.") - (let loop () - ;; sync for filesystem local db writes - ;; - (mutex-lock! *db-multi-sync-mutex*) - (let* ((need-sync (>= *db-last-access* *db-last-sync*)) ;; no sync since last write - (sync-in-progress *db-sync-in-progress*) - (should-sync (and (not *time-to-exit*) - (> (- (current-seconds) *db-last-sync*) 5))) ;; sync every five seconds minimum - (start-time (current-seconds)) - (mt-mod-time (file-modification-time mtpath)) - (recently-synced (< (- start-time mt-mod-time) 4)) - (will-sync (and (or need-sync should-sync) - (not sync-in-progress) - (not recently-synced)))) - (debug:print-info 13 *default-log-port* "WD writable-watchdog top of loop. need-sync="need-sync" sync-in-progress="sync-in-progress" should-sync="should-sync" start-time="start-time" mt-mod-time="mt-mod-time" recently-synced="recently-synced" will-sync="will-sync) - ;; (if recently-synced (debug:print-info 0 *default-log-port* "Skipping sync due to recently-synced flag=" recently-synced)) - ;; (debug:print-info 0 *default-log-port* "need-sync: " need-sync " sync-in-progress: " sync-in-progress " should-sync: " should-sync " will-sync: " will-sync) - (if will-sync (set! *db-sync-in-progress* #t)) - (mutex-unlock! *db-multi-sync-mutex*) - (if will-sync - (let ((res (common:sync-to-megatest.db dbstruct))) ;; did we sync any data? If so need to set the db touched flag to keep the server alive - (if (> res 0) ;; some records were transferred, keep the db alive - (begin - (mutex-lock! *heartbeat-mutex*) - (set! *db-last-access* (current-seconds)) - (mutex-unlock! *heartbeat-mutex*) - (debug:print-info 0 *default-log-port* "sync called, " res " records transferred.")) - (debug:print-info 2 *default-log-port* "sync called but zero records transferred")))) - (if will-sync - (begin - (mutex-lock! *db-multi-sync-mutex*) - (set! *db-sync-in-progress* #f) - (set! *db-last-sync* start-time) - (mutex-unlock! *db-multi-sync-mutex*))) - (if (and debug-mode - (> (- start-time last-time) 60)) - (begin - (set! last-time start-time) - (debug:print-info 4 *default-log-port* "timestamp -> " (seconds->time-string (current-seconds)) ", time since start -> " (seconds->hr-min-sec (- (current-seconds) *time-zero*)))))) - - ;; keep going unless time to exit - ;; - (if (not *time-to-exit*) - (let delay-loop ((count 0)) - ;;(debug:print-info 13 *default-log-port* "delay-loop top; count="count" pid="(current-process-id)" this-wd-num="this-wd-num" *time-to-exit*="*time-to-exit*) - - (if (and (not *time-to-exit*) - (< count 4)) ;; was 11, changing to 4. - (begin - (thread-sleep! 1) - (delay-loop (+ count 1)))) - (if (not *time-to-exit*) (loop)))) - (if (common:low-noise-print 30) - (debug:print-info 0 *default-log-port* "Exiting watchdog timer, *time-to-exit* = " *time-to-exit*" pid="(current-process-id)" this-wd-num="this-wd-num))))))) - ;; 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 (common:on-homehost?) - (let ((dbstruct (db:setup))) - (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.") - (common:writable-watchdog dbstruct))) - (debug:print-info 13 *default-log-port* "watchdog done.")) - (debug:print-info 13 *default-log-port* "no need for watchdog on non-homehost"))) + (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.") + (server:writable-watchdog dbstruct))) + (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) (on-exit (lambda () 0)) ;;(debug:print-info 13 *default-log-port* "std-exit-procedure called; *time-to-exit*="*time-to-exit*) @@ -776,14 +812,15 @@ (begin (sqlite3:interrupt! db) (sqlite3:finalize! db #t) ;; (vector-set! *task-db* 0 #f) (set! *task-db* #f))))) - (if (and *runremote* - (remote-conndat *runremote*)) - (begin - (http-client#close-all-connections!))) ;; for http-client + (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...") @@ -805,16 +842,27 @@ (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 " exiting promptly") + (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-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 ;;====================================================================== @@ -858,19 +906,19 @@ #f (let loop ((hed (car cmds)) (tal (cdr cmds))) (let ((res (with-input-from-pipe (conc "which " hed) read-line))) (if (and (string? res) - (file-exists? 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 (file-exists? exe-path) + (if (common:file-exists? exe-path) (handle-exceptions exn #f (pathname-directory (pathname-directory @@ -886,12 +934,14 @@ (tal (cdr dirs))) (let ((res (or (and (directory? hed) (file-write-access? hed) hed) (handle-exceptions - exn - #f + exn + (begin + (debug:print-info 0 *default-log-port* "could not create " hed ", this might cause problems down the road.") + #f) (create-directory hed #t))))) (if (and (string? res) (directory? res)) res (if (null? tal) @@ -965,14 +1015,18 @@ (or (args:get-arg "-status")(args:get-arg ":status"))) (define (common:args-get-testpatt rconf) (let* (;; (tagexpr (args:get-arg "-tagexpr")) ;; (tags-testpatt (if tagexpr (string-join (runs:get-tests-matching-tags tagexpr) ",") #f)) - (testpatt-key (if (args:get-arg "--modepatt") (args:get-arg "--modepatt") "TESTPATT")) + (testpatt-key (or (args:get-arg "-modepatt") (args:get-arg "--modepatt") "TESTPATT")) (args-testpatt (or (args:get-arg "-testpatt") (args:get-arg "-runtests") "%")) (rtestpatt (if rconf (runconfigs-get rconf testpatt-key) #f))) (cond + ((args:get-arg "--modepatt") ;; modepatt is a forced setting, when set it MUST refer to an existing PATT in the runconfig + (if rconf + (runconfigs-get rconf testpatt-key) + #f)) ;; We do NOT fall back to "%" ;; (tags-testpatt ;; (debug:print-info 0 *default-log-port* "-tagexpr "tagexpr" selects testpatt "tags-testpatt) ;; tags-testpatt) ((and (equal? args-testpatt "%") rtestpatt) (debug:print-info 0 *default-log-port* "testpatt defined in "testpatt-key" from runconfigs: " rtestpatt) @@ -986,44 +1040,60 @@ (begin (if message (debug:print-info 0 *default-log-port* message)) #f) (thunk) )) -(define (common:file-exists? path-string) +(define (common:file-exists? path-string #!key (silent #f)) ;; this avoids stack dumps in the case where ;;;; TODO: catch permission denied exceptions and emit appropriate warnings, eg: system error while trying to access file: "/nfs/pdx/disks/icf_env_disk001/bjbarcla/gwa/issues/mtdev/randy-slow/reproduce/q... (common:false-on-exception (lambda () (file-exists? path-string)) - message: (conc "Unable to access path: " path-string) + message: (if (not silent) + (conc "Unable to access path: " path-string) + #f) )) (define (common:directory-exists? path-string) ;;;; TODO: catch permission denied exceptions and emit appropriate warnings, eg: system error while trying to access file: "/nfs/pdx/disks/icf_env_disk001/bjbarcla/gwa/issues/mtdev/randy-slow/reproduce/q... (common:false-on-exception (lambda () (directory-exists? path-string)) message: (conc "Unable to access path: " path-string) )) +;; does the directory exist and do we have write access? +;; +;; returns the directory or #f +;; +(define (common:directory-writable? path-string) + (handle-exceptions + exn + #f + (if (and (directory-exists? path-string) + (file-write-access? path-string)) + path-string + #f))) (define (common:get-linktree) (or (getenv "MT_LINKTREE") - (or (and *configdat* - (configf:lookup *configdat* "setup" "linktree")) + (if *configdat* + (configf:lookup *configdat* "setup" "linktree") (if *toppath* (conc *toppath* "/lt") - (if (file-exists? "megatest.config") ;; we are in the toppath (new area, mtutils compatible) - (conc (current-directory) "/lt") - #f))))) + #f)))) (define (common:args-get-runname) (let ((res (or (args:get-arg "-runname") (args:get-arg ":runname") (getenv "MT_RUNNAME")))) ;; (if res (set-environment-variable "MT_RUNNAME" res)) ;; not sure if this is a good idea. side effect and all ... res)) + +(define (common:get-fields cfgdat) + (let ((fields (hash-table-ref/default cfgdat "fields" '()))) + (map car fields))) (define (common:args-get-target #!key (split #f)(exit-if-bad #f)) - (let* ((keys (if (hash-table? *configdat*) (keys:config-get-fields *configdat*) '())) + (let* ((keys (if (hash-table? *configdat*) (common:get-fields *configdat*) '())) (numkeys (length keys)) (target (or (args:get-arg "-reqtarg") (args:get-arg "-target") (getenv "MT_TARGET"))) (tlist (if target (string-split target "/" #t) '())) @@ -1041,10 +1111,20 @@ (begin (debug:print-error 0 *default-log-port* "Invalid target, spaces or blanks not allowed \"" target "\", target should be: " (string-intersperse keys "/") ", have " tlist " for elements") (if exit-if-bad (exit 1)) #f) #f)))) + +;; looking only (at least for now) at the MT_ variables craft the full testname +;; +(define (common:get-full-test-name) + (if (getenv "MT_TEST_NAME") + (if (and (getenv "MT_ITEMPATH") + (not (equal? (getenv "MT_ITEMPATH") ""))) + (getenv "MT_TEST_NAME") + (conc (getenv "MT_TEST_NAME") "/" (getenv "MT_ITEMPATH"))) + #f)) ;; logic for getting homehost. Returns (host . at-home) ;; IF *toppath* is not set, wait up to five seconds trying every two seconds ;; (this is to accomodate the watchdog) ;; @@ -1079,11 +1159,11 @@ (begin (mutex-unlock! *homehost-mutex*) (debug:print 0 *default-log-port* "ERROR: 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 (file-exists? hhf) + (if (common:file-exists? hhf) (with-input-from-file hhf read-line) (if (file-write-access? *toppath*) (begin (with-output-to-file hhf (lambda () @@ -1107,14 +1187,24 @@ #f))) ;; do we honor the caches of the config files? ;; (define (common:use-cache?) - (not (or (args:get-arg "-no-cache") - (and *configdat* - (equal? (configf:lookup *configdat* "setup" "use-cache") "no"))))) - + (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)) @@ -1131,17 +1221,10 @@ (begin (debug:print-info 0 *default-log-port* "forcing use of server, force setting is \"" force-setting "\".") #t) #f))) -;; do we honor the caches of the config files? -;; -(define (common:use-cache?) - (not (or (args:get-arg "-no-cache") - (and *configdat* - (equal? (configf:lookup *configdat* "setup" "use-cache") "no"))))) - ;;====================================================================== ;; M I S C L I S T S ;;====================================================================== ;; items in lista are matched value and position in listb @@ -1295,10 +1378,33 @@ 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 ;;====================================================================== @@ -1358,77 +1464,114 @@ ;; (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 5)) + (let* ((fullpath (conc *toppath* "/logs/" key "-" dtype ".log"))) + (if (and (file-exists? fullpath) + (file-read-access? fullpath)) + (handle-exceptions + exn + #f + (debug:print 2 *default-log-port* "reading file " fullpath) + (let ((real-age (- (current-seconds)(file-change-time fullpath)))) + (if (< real-age age) + (with-input-from-file fullpath read) + (begin + (debug:print 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)))) + +(define (common:write-cached-info key dtype dat) + (let* ((fullpath (conc *toppath* "/logs/" key "-" dtype ".log"))) + (handle-exceptions + exn + #f + (with-output-to-file fullpath (lambda ()(pp dat)))))) ;; get cpu load by reading from /proc/loadavg, return all three values ;; (define (common:get-cpu-load remote-host) - (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)))))) + (let* ((actual-hostname (or remote-host (get-host-name)))) + (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))))))) + (common:write-cached-info actual-hostname "cpu-load" result) + result)))) ;; 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 ((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))) - (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)))) - (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))))))))) + (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))) @@ -1435,16 +1578,16 @@ ;; 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)) - (load (car loadinfo)) - (load-sample-time (cdr loadinfo)) - (load-sample-age (- (current-seconds) load-sample-time)) - (loadinfo-timeout-seconds 20) - (host-last-update-timeout-seconds 10) + (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 ((< load-sample-age loadinfo-timeout-seconds) (list #t @@ -1456,14 +1599,18 @@ (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)))) + (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))))) - + (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 @@ -1481,80 +1628,133 @@ (host-reachable-set! rec is-reachable) (host-last-update-set! rec last-reached-time) (host-last-cpuload-set! rec load))) hosts))) -(define (common:get-least-loaded-host hosts-raw) - (let* ((hosts (filter (lambda (x) - (string-match (regexp "^\\S+$") x)) - hosts-raw)) - (best-host #f) +;; 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))) - (common:update-host-loads-table hosts) - (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)))) - (reachable (host-reachable rec)) - (load (host-last-cpuload rec))) - (cond - ((not reachable) #f) - ((< (+ load (/ (random 250) 1000)) ;; add a random factor to keep from getting in a rut - (+ best-load (/ (random 250) 1000)) ) - (set! best-load load) - (set! best-host hostname))))) - hosts) - best-host)) - - - - -(define (common:wait-for-cpuload maxload numcpus waitdelay #!key (count 1000) (msg #f)(remote-host #f)) + (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-cpuload maxload-in numcpus-in waitdelay #!key (count 1000) (msg #f)(remote-host #f)) (let* ((loadavg (common:get-cpu-load remote-host)) + (numcpus (if (< 1 numcpus-in) ;; not possible + (common:get-num-cpus remote-host) + numcpus-in)) + (maxload (max maxload-in 0.5)) ;; so maxload must be greater than 0.5 for now BUG - FIXME? (first (car loadavg)) (next (cadr loadavg)) - (adjload (* maxload numcpus)) - (loadjmp (- first next))) + (adjload (* maxload (max 1 numcpus))) ;; possible bug where numcpus (or could be maxload) is zero, crude fallback is to at least use 1 + (loadjmp (- first next)) + (adjwait (+ (random 10)(/ (- 1000 count) 10) waitdelay))) ;; add some randomness to the time to break any alignment where netbatch dumps many jobs to machines simultaneously (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))) + (debug:print-info 0 *default-log-port* "server start delayed " adjwait " seconds due to load " first " exceeding max of " adjload " on server " (or remote-host (get-host-name)) " (normalized load-limit: " maxload ") " (if msg msg "")) + (thread-sleep! adjwait) + (common:wait-for-cpuload maxload numcpus waitdelay count: (- count 1) msg: msg remote-host: remote-host)) ((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)))))) + (debug:print-info 0 *default-log-port* "waiting " adjwait " seconds due to load jump " loadjmp " > numcpus " numcpus (if msg msg "")) + (thread-sleep! adjwait) + (common:wait-for-cpuload maxload numcpus waitdelay count: (- count 1) msg: msg remote-host: remote-host))))) + +(define (common:wait-for-homehost-load maxload 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)) + (numcpus (common:get-num-cpus hh))) + (common:wait-for-normalized-load maxload msg hh))) (define (common:get-num-cpus remote-host) - (let ((proc (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))))))) - (if remote-host - (with-input-from-pipe - (conc "ssh " remote-host " cat /proc/cpuinfo") - proc) - (with-input-from-file "/proc/cpuinfo" proc)))) + (let* ((actual-host (or remote-host (get-host-name)))) + (or (common:get-cached-info actual-host "num-cpus" age: 86400) ;; hosts had better not be changing the number of cpus too often! + (let* ((proc (lambda () + (let loop ((numcpu 0) + (inl (read-line))) + (if (eof-object? inl) + (begin + (common:write-cached-info remote-host "num-cpus" numcpu) + numcpu) + (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)))) + (common:write-cached-info actual-host "num-cpus" result) + result)))) ;; wait for normalized cpu load to drop below maxload ;; -(define (common:wait-for-normalized-load maxload #!key (msg #f)(remote-host #f)) +(define (common:wait-for-normalized-load maxload msg remote-host) (let ((num-cpus (common:get-num-cpus remote-host))) - (common:wait-for-cpuload maxload num-cpus 15 msg: msg))) + (common:wait-for-cpuload maxload num-cpus 15 msg: msg remote-host: remote-host))) (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)) @@ -1708,11 +1908,12 @@ (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") @@ -1722,32 +1923,55 @@ (val (cdr keyval)) (delim (if (string-search whitesp val) "\"" ""))) (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") + ("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. ;; @@ -1770,10 +1994,11 @@ (hash-table-for-each vars (lambda (var val) (setenv var val))) vars)) + (define (common:run-a-command cmd #!key (with-vars #f)) (let* ((pre-cmd (dtests:get-pre-command)) (post-cmd (dtests:get-post-command)) (fullcmd (if (or pre-cmd post-cmd) @@ -1788,27 +2013,30 @@ ;; 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)) @@ -2091,25 +2319,47 @@ (number->string x 16)) (map string->number (string-split instr))) "/")) -(define (common:faux-lock keyname) - (if (rmt:get-var keyname) - #f +;;====================================================================== +;; 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:set-var keyname (conc (current-process-id))) - (equal? (conc (current-process-id)) (conc (rmt:get-var keyname)))))) + (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:get-var keyname)))) + (if (or force (equal? (conc (current-process-id)) (conc (rmt:no-sync-get/default keyname #f)))) (begin - (if (rmt:get-var keyname) (rmt:del-var keyname)) + (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:in-running-test?) (and (args:get-arg "-execute") (get-environment-variable "MT_CMDINFO"))) (define (common:get-color-from-status status) (cond @@ -2120,93 +2370,81 @@ ((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: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;")))) +;; ;;====================================================================== +;; ;; 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 ;;====================================================================== ;; @@ -2217,10 +2455,16 @@ ;; ;; [host-types] ;; 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 +;; +;; [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 ;; % nbgeneral @@ -2247,12 +2491,23 @@ (let ((launcher (configf:lookup configdat "host-types" host-type))) (if 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 ((targ-host (common:get-least-loaded-host (cdr launcher-parts)))) - (conc "remrun " targ-host)) + (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))))) launcher)) (begin (debug:print-info 0 *default-log-port* "WARNING: no launcher found for host-type " host-type) (if (null? tal) fallback-launcher @@ -2260,11 +2515,51 @@ ;; 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: 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 @@ -2271,12 +2566,266 @@ ;; (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) ;; 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 pktsdir 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 + #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*))) 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") @@ -147,15 +156,17 @@ (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 ((dp-args - (append - (list 0 *default-log-port* - (conc location "@"(/ (- (current-milliseconds) *BB-process-starttime*) 1000)" ") ) - in-args))) + (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)) Index: configf.scm ================================================================== --- configf.scm +++ configf.scm @@ -23,18 +23,18 @@ ;; 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))))))))) @@ -77,10 +77,14 @@ (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|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))) @@ -92,11 +96,11 @@ (result #f) (start-time (current-seconds)) (cmdsym (string->symbol cmdtype)) (fullcmd (case cmdsym ((scheme scm) (conc "(lambda (ht)" cmd ")")) - ((system) (conc "(lambda (ht)(system \"" 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 "\"))" @@ -176,11 +180,27 @@ (configf:process-line inl ht allow-processing))))) (if (and (string? res) (not (equal? (hash-table-ref/default settings "trim-trailing-spaces" "no") "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 @@ -217,22 +237,34 @@ ;; 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) +(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)) + (post-section-procs '()) (apply-wildcards #t) ) (debug:print 9 *default-log-port* "START: " 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 (file-exists? path))) ;; for case where we are handed a port + (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 (if (string? path) @@ -265,146 +297,183 @@ (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: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 (common: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: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 (file-exists? include-script)(file-execute-access? include-script)) - (let* ((new-inp-port (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) - (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)) - (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))) + (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))) + (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 + (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)))) (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)) @@ -423,21 +492,51 @@ (cadr match) #f)) )) #f)) +;; 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 configf:lookup config-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 cfdat section varname #!key (default #f)) + (let* ((val (configf:lookup *configdat* 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 @@ -487,11 +586,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 @@ -591,11 +690,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 () @@ -663,36 +762,33 @@ #f (configf:alist->config (with-input-from-file fname read)))) (define (configf:write-alist cdat fname) - (if (common:faux-lock 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 - #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) - (begin - (debug:print 0 *default-log-port* "WARNING: could not get faux-lock on " fname) - #f))) - + (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 + #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 dashboard-context-menu.scm Index: dashboard-context-menu.scm ================================================================== --- /dev/null +++ dashboard-context-menu.scm @@ -0,0 +1,348 @@ +;;====================================================================== +;; 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 program is distributed WITHOUT ANY WARRANTY; without even the +;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR +;; PURPOSE. +;;====================================================================== + +;;====================================================================== +;; 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* (;; (cfg-sh (conc *common:this-exe-dir* "/cfg.sh")) + ;; (cmd (conc + ;; (if (common:file-exists? cfg-sh) + ;; (conc "source "cfg-sh" && ") + ;; "") + ;; *common:this-exe-fullpath* + ;; " -test " run-id "," test-id + ;; " &")) + (cmd (conc *common:this-exe-dir*"/../dashboard " + "-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") + (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 @@ -28,10 +28,11 @@ (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") @@ -40,16 +41,26 @@ ;;====================================================================== (define *dashboard-comment-share-slot* #f) (define (dtests:get-pre-command #!key (default-override #f)) - (let ((cfg-ovrd (configf:lookup *configdat* "dashboard" "pre-command"))) - (or cfg-ovrd default-override "viewscreen "))) ;; "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" @@ -233,20 +244,20 @@ ))))) ;; 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) + (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)))) (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 &"))))) + (subrun:launch-dashboard test-run-dir)))) (iup:vbox)))) ;; use a global for setting the buttons colors ;; state status teststeps (define *state-status* (vector #f #f #f)) @@ -458,11 +469,11 @@ "/")) (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"))) ;; no rush but it would be good to convert this call to use runconfig:read - (if (file-exists? runconfigf) + (if (common:file-exists? runconfigf) (handle-exceptions exn #f ;; do nothing, just keep on trucking .... (setup-env-defaults runconfigf run-id (make-hash-table) keydat environ-patt: keystring)) (make-hash-table)))) @@ -469,21 +480,21 @@ (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 ;; NOTE: I've no idea why this was written this way. Research, study and fix needed! - (tests:get-testconfig (db:test-get-testname testdat) (db:test-get-item-path testdat) test-registry #f) - (tests:get-testconfig (db:test-get-testname testdat) item-path test-registry #t)))) + (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 "&")) (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 "&")) (dcommon:run-html-viewer lfilename) (message-window (conc "File " lfilename " not found")))))) (xterm (lambda (x) (if (directory-exists? rundir) @@ -496,11 +507,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) @@ -616,15 +627,16 @@ " -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" ))) 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,12 +40,13 @@ (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") @@ -47,11 +57,11 @@ (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 @@ -85,10 +95,11 @@ "-v" "-q" "-use-db-cache" "-skip-version-check" "-repl" + "-rh5.11" ;; fix to allow running on rh5.11 ) args:arg-hash 0)) (if (not (null? remargs)) @@ -105,10 +116,18 @@ ;; (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)))) @@ -204,11 +223,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 @@ -222,11 +243,11 @@ (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") "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) @@ -313,10 +334,12 @@ (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"))) @@ -339,11 +362,11 @@ (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 (db:dispatch-query (db:get-access-mode) rmt:get-keys db:get-keys)) + (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 @@ -567,12 +590,11 @@ (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) - (db:dispatch-query access-mode rmt:get-tests-for-run db:get-tests-for-run - run-id testnamepatt states statuses ;; run-id testpatt states statuses + (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 @@ -642,17 +664,15 @@ ;; create a virtual table of all the tests ;; keypatts: ( (KEY1 "abc%def")(KEY2 "%") ) ;; (define (update-rundat tabdat runnamepatt numruns testnamepatt keypatts) (let* ((access-mode (dboard:tabdat-access-mode tabdat)) - (keys (db:dispatch-query access-mode rmt:get-keys db:get-keys)) + (keys (rmt:get-keys)) (last-runs-update (- (dboard:tabdat-last-runs-update tabdat) 2)) - (allruns (db:dispatch-query access-mode rmt:get-runs db:get-runs - runnamepatt numruns (dboard:tabdat-start-run-offset tabdat) keypatts)) + (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 (db:dispatch-query access-mode rmt:get-runs-by-patt db: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))) @@ -725,15 +745,13 @@ ;; (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 (db:dispatch-query access-mode rmt:get-runs db:get-runs - runnamepatt numruns (dboard:tabdat-start-run-offset tabdat) keypatts)) + (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 (db:dispatch-query access-mode rmt:get-runs-by-patt db:get-runs-by-patt - keys "%" #f #f #f #f 0)) ;; last-runs-update));;'("id" "runname") + (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))) @@ -792,11 +810,19 @@ (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 - (if (> elapsed-time 2)(print "NOTE: updates are taking a long time, " elapsed-time "s elapsed.")) + (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))))))) + (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))))))) @@ -1001,11 +1027,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) @@ -1085,10 +1111,11 @@ (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) @@ -1376,11 +1403,11 @@ ;; 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) + (dboard:runs-tree-browser commondat tabdat) (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))) @@ -1397,14 +1424,20 @@ ;; (let ((logs-tb (iup:textbox #:expand "YES" ;; #:multiline "YES"))) ;; (dboard:tabdat-logs-textbox-set! tabdat logs-tb) ;; logs-tb)) +;; browse runs as a tree. Used in both "Runs" tab and +;; in the runs control panel. +;; (define (dboard:runs-tree-browser commondat tabdat) - (let* ((txtbox (iup:textbox #:action (lambda (val a b) + (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:tabdat-target-set! tabdat (string-split b "/"))) (dashboard:update-run-command tabdat)) "command-testname-selector tb action")) #:value (dboard:test-patt->lines (dboard:tabdat-test-patts-use tabdat)) @@ -1412,13 +1445,13 @@ ;; #:size "10x30" )) (tb (iup:treebox #:value 0 - #: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" #:size "10x" #:selection-cb (lambda (obj id state) (debug:catch-and-dump (lambda () @@ -1440,11 +1473,14 @@ (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) - (iup:vbox tb txtbox))) + (iup:detachbox + (iup:vbox + tb + txtbox)))) ;;====================================================================== ;; R U N C O N T R O L S ;;====================================================================== ;; @@ -1509,11 +1545,11 @@ (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 @@ -1554,15 +1590,15 @@ (let* ((hb1 (iup:hbox)) (graph-cell-table (dboard:tabdat-graph-cell-table tabdat)) (changed #f) (graph-matrix (iup:matrix #:alignment1 "ALEFT" - #:expand "YES" ;; "HORIZONTAL" + ;; #:expand "YES" ;; "HORIZONTAL" #:scrollbar "YES" #:numcol 10 #:numlin 20 - #:numcol-visible (min 8) + #:numcol-visible 5 ;; (min 8) #:numlin-visible 1 #:click-cb (lambda (obj row col status) (let* ((graph-cell (conc row ":" col)) @@ -1611,35 +1647,35 @@ (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* ((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 (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)) @@ -1655,16 +1691,17 @@ (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"))) (< time-a time-b))))) (changed #f) (last-runs-update (dboard:tabdat-last-runs-update tabdat)) - (runs-dat (db:dispatch-query access-mode rmt:get-runs-by-patt db:get-runs-by-patt - (dboard:tabdat-keys tabdat) "%" #f #f #f #f last-runs-update))) + (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)))) (if (not (hash-table-ref/default (dboard:tabdat-path-run-ids tabdat) run-path #f)) @@ -1689,16 +1726,20 @@ (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))) - (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))))))) + (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 (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)) @@ -1727,12 +1768,11 @@ (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 (db:dispatch-query access-mode rmt:get-runs-by-patt db:get-runs-by-patt - (dboard:tabdat-keys tabdat) "%" #f #f #f #f last-runs-update)) + (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) @@ -1744,13 +1784,11 @@ (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 (db:dispatch-query (dboard:tabdat-access-mode tabdat) - rmt:get-runs-by-patt db:get-runs-by-patt - (dboard:tabdat-keys tabdat) "%" #f #f #f #f last-runs-update)) + (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))) @@ -1865,11 +1903,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") @@ -1902,11 +1940,11 @@ (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) @@ -2046,13 +2084,14 @@ ;; (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) @@ -2108,27 +2147,27 @@ (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))) - (testpanel-cmd (conc toolpath " -test " (dboard:tabdat-curr-run-id tabdat) "," test-id " &"))) + (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 - (system testpanel-cmd)) + (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:popup-menu run-id test-id target runname test-name testpatt item-test-path test-info) ;; 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") ) (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:popup-menu run-id test-id target runname test-name testpatt item-test-path test-info) ;; 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") ) ) @@ -2159,10 +2198,28 @@ ;;====================================================================== ;; R U N S ;;====================================================================== +(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 @@ -2181,10 +2238,20 @@ (iup:hbox (iup:button "Quit" #:action (lambda (obj) (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 () @@ -2223,17 +2290,17 @@ (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")) @@ -2263,217 +2330,80 @@ ))) - (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 run-id test-id target runname test-name testpatt item-test-path test-info) - (iup:menu - (iup:menu-item - "Test Control Panel" - #:action - (lambda (obj) - (let* ((toolpath (car (argv))) - (testpanel-cmd - (conc toolpath " -test " run-id "," test-id " &"))) - (system testpanel-cmd) - ))) - - (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."))))) - ) - (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)))) - (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")))) - - - (iup:menu-item - "Run" - (iup:menu - (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")))))) - (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)))) - )))) + (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)) + (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)) ;; name for run-summary structure @@ -2506,10 +2436,13 @@ (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) + ;; each field (field name is "x" var) live updates + ;; the search filter as it is typed + (dboard:tabdat-target-set! runs-dat #f) ;; ensure the 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))))) @@ -2605,24 +2538,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 run-id test-id target runname test-name testpatt item-test-path test-info) ;; 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 @@ -2630,20 +2561,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 @@ -2688,10 +2622,11 @@ runs-view (dashboard:runs-summary commondat onerun-dat tab-num: 2) ;; (dashboard:new-view db data new-view-dat tab-num: 3) (dashboard:run-controls commondat runcontrols-dat tab-num: 3) (dashboard:run-times commondat runtimes-dat tab-num: 4) + ;; (dashboard:runs-summary commondat onerun-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" "Run Summary") @@ -2758,11 +2693,11 @@ (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 @@ -2887,13 +2822,11 @@ ;; run times tab data updater ;; (define (dashboard:run-times-tab-run-data-updater commondat tabdat tab-num) (let* ((access-mode (dboard:tabdat-access-mode tabdat)) (last-runs-update (dboard:tabdat-last-runs-update tabdat)) - (runs-dat (db:dispatch-query access-mode - rmt:get-runs-by-patt db:get-runs-by-patt - (dboard:tabdat-keys tabdat) "%" #f #f #f #f last-runs-update)) + (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)) (vector-ref runs-dat 1)) @@ -3475,11 +3408,11 @@ ;; The heavy lifting starts here ;;====================================================================== (define (main) (let ((mtdb-path (conc *toppath* "/megatest.db"))) ;; - (if (and (file-exists? mtdb-path) + (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... @@ -3534,12 +3467,12 @@ (thread-start! th2) (thread-join! th2))))) ;; ease debugging by loading ~/.dashboardrc (let ((debugcontrolf (conc (get-environment-variable "HOME") "/.dashboardrc"))) - (if (file-exists? debugcontrolf) + (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,20 @@ +# 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,20 @@ +# 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,23 @@ +# 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/megatest.config ================================================================== --- datashare-testing/megatest.config +++ datashare-testing/megatest.config @@ -1,4 +1,19 @@ +# 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,19 @@ +# 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 @@ -226,11 +226,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 +413,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 +518,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 +692,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 +706,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 +785,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,14 +1,23 @@ -;;====================================================================== +;====================================================================== ;; 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 . +;; ;;====================================================================== ;;====================================================================== ;; Database access ;;====================================================================== @@ -188,55 +197,48 @@ ;; 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 . junk) ;; run-id) - (let* ((dbdir (common:get-db-tmp-area))) - (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))) - dbdir)) +(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 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-open-mutex* (make-mutex)) (define (db:lock-create-open fname initproc) (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. + ;; (mutex-lock! *db-open-mutex*) ;; tried this mutex, not clear it helped. (if file-write ;; dir-writable (condition-case (let* ((lockfname (conc fname ".lock")) (readyfname (conc parent-dir "/.ready-" raw-fname)) - (readyexists (file-exists? readyfname))) + (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 (make-busy-timeout 136000)) (sqlite3:execute db "PRAGMA synchronous = 0;") (if (not file-exists) (begin + (if (and (configf:lookup *configdat* "setup" "use-wal") (string-match "^/tmp/.*" fname)) ;; this is a file in /tmp (sqlite3:execute db "PRAGMA journal_mode=WAL;") - (print "Creating " fname " in NON-WAL mode.")) + (debug:print 2 *default-log-port* "Creating " fname " in NON-WAL mode.")) (initproc db))) (if (not readyexists) (begin (common:simple-file-release-lock lockfname) (with-output-to-file @@ -254,11 +256,11 @@ (condition-case (begin (debug:print 2 *default-log-port* "WARNING: opening db in non-writable dir " fname) (let ((db (sqlite3:open-database fname))) - ;;(mutex-unlock! *db-open-mutex*) + ;; (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.")) @@ -272,11 +274,11 @@ ;; ;; 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* ((dbfile (db:dbfile-path run-id)) ;; (conc toppath "/db/" run-id ".db")) -;; (dbexists (file-exists? dbfile)) +;; (dbexists (common:file-exists? dbfile)) ;; (db (db:lock-create-open dbfile (lambda (db) ;; (handle-exceptions ;; exn ;; (begin ;; ;; (release-dot-lock dbpath) @@ -307,19 +309,19 @@ ;; (db:sync-tables db:sync-tests-only *megatest-db* db) ;; db)) ;; 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)) ;; TODO: actually use areapath +(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* ((dbpath (db:dbfile-path )) ;; path to tmp db area - (dbexists (file-exists? dbpath)) + (dbexists (common:file-exists? dbpath)) (tmpdbfname (conc dbpath "/megatest.db")) - (dbfexists (file-exists? tmpdbfname)) ;; (conc dbpath "/megatest.db"))) - (mtdbexists (file-exists? (conc *toppath* "/megatest.db"))) + (dbfexists (common:file-exists? tmpdbfname)) ;; (conc dbpath "/megatest.db"))) + (mtdbexists (common:file-exists? (conc *toppath* "/megatest.db"))) (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")) @@ -337,15 +339,16 @@ (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) ;; (mutex-unlock! *rundb-mutex*) - (if (or (not dbfexists) - (and modtimedelta - (> modtimedelta 10))) ;; if db in tmp is over ten seconds older than the file in MTRA then do a sync back + (if (and (or (not dbfexists) + (and modtimedelta + (> modtimedelta 10))) ;; if db in tmp is over ten seconds older than the file in MTRA then do a sync back + do-sync) (begin - (debug:print 4 *default-log-port* "filling db " (db:dbdat-get-path tmpdb) " with data \n from " (db:dbdat-get-path mtdb) " mod time delta: " modtimedelta) + (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) (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 @@ -353,23 +356,22 @@ ;; Make the dbstruct, setup up auxillary db's and call for main db at least once ;; ;; called in http-transport and replicated in rmt.scm for *local* access. ;; -(define (db:setup #!key (areapath #f)) +(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) + (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 @@ -381,11 +383,11 @@ ;; NOTE: returns a dbdat not a dbstruct! ;; (define (db:open-megatest-db #!key (path #f)(name #f)) (let* ((dbdir (or path *toppath*)) (dbpath (conc dbdir "/" (or name "megatest.db"))) - (dbexists (file-exists? dbpath)) + (dbexists (common:file-exists? dbpath)) (db (db:lock-create-open dbpath (lambda (db) (db:initialize-main-db db) ;;(db:initialize-run-id-db db) ))) @@ -410,10 +412,25 @@ (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 #!key (try-num 3)) + (if (<= try-num 0) + #f + (handle-exceptions + exn + (begin + (thread-sleep! 3) + (sqlite3:interrupt! db) + (db:safely-close-sqlite3-db db try-num: (- try-num 1))) + (if (sqlite3:database? db) + (begin + (sqlite3:finalize! db) + #t) + #f)))) ;; close all opened run-id dbs (define (db:close-all dbstruct) (if (dbr:dbstruct? dbstruct) (handle-exceptions @@ -425,15 +442,16 @@ (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)))) (map (lambda (db) - (if (sqlite3:database? db) - (sqlite3:finalize! db))) + (db:safely-close-sqlite3-db db)) +;; (if (sqlite3:database? db) +;; (sqlite3:finalize! db))) tdbs) - (if (sqlite3:database? mdb) (sqlite3:finalize! mdb)) - (if (sqlite3:database? rdb) (sqlite3:finalize! rdb)))))) + (db:safely-close-sqlite3-db mdb) ;; (if (sqlite3:database? mdb) (sqlite3:finalize! mdb)) + (db:safely-close-sqlite3-db rdb))))) ;; (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)) @@ -471,20 +489,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) @@ -492,11 +512,12 @@ '("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 dbstruct) (let ((keys (db:get-keys dbstruct))) @@ -508,11 +529,11 @@ (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" "contour")))) + (list "runname" "state" "status" "owner" "event_time" "comment" "fail_count" "pass_count" "contour" "last_update")))) (list "test_meta" '("id" #f) '("testname" #f) '("owner" #f) '("description" #f) @@ -537,11 +558,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 @@ -613,11 +634,11 @@ exn (begin (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) @@ -661,26 +682,42 @@ (numrecs (make-hash-table)) (start-time (current-milliseconds)) (tot-count 0)) (for-each ;; table (lambda (tabledat) - (let* ((tablename (car tabledat)) - (fields (cdr tabledat)) - (use-last-update (if last-update - (if (pair? last-update) - (member (car last-update) ;; last-update field name - (map car fields)) - (begin - (debug:print 0 *default-log-port* "ERROR: parameter last-update for db:sync-tables must be a pair, received: " last-update) ;; found in fields - #f)) - #f)) + (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))) (full-sel (conc "SELECT " (string-intersperse (map car fields) ",") " FROM " tablename (if use-last-update ;; apply last-update criteria - (conc " " (car last-update) ">=" (cdr last-update)) + (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 '()) @@ -834,12 +871,50 @@ (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;")) + END;") + (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)) @@ -857,11 +932,11 @@ (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 (file-exists? target) + (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)) @@ -871,41 +946,41 @@ (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 (file-exists? megatest-db) - (file-write-access? megatest-db)) - (begin - (common:sync-to-megatest.db '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) - )))) +;; ;; 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 @@ -915,147 +990,114 @@ ;; '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) - - ;; kill servers - (if (member 'killservers options) - (for-each - (lambda (server) - (match-let (((mod-time host port start-time pid) server)) - (if (and host pid) - (tasks:kill-server host pid)))) - servers)) - - ;; clear out junk records - ;; - (if (member 'dejunk options) - (begin - (db:delay-if-busy mtdb) ;; ok to delay on mtdb - (db:clean-up mtdb) - (db:clean-up tmpdb) - (db:clean-up refndb))) - - ;; 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 - (set! data-synced - (+ (db:sync-tables (db:sync-all-tables-list dbstruct) #f mtdb tmpdb refndb) - data-synced))) - ;; (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-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) - (set! data-synced - (+ (db:sync-tables (db:sync-all-tables-list dbstruct) #f tmpdb refndb mtdb) - data-synced))) - - - - (if (member 'schema options) - (begin - (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)))) - - ;; (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 '())) - ;; ;; first fix schema if needed - ;; (map - ;; (lambda (th) - ;; (thread-join! th)) - ;; (map - ;; (lambda (run-id) - ;; (thread-start! - ;; (make-thread - ;; (lambda () - ;; (let* ((fromdb (if toppath (make-dbr:dbstruct path: toppath local: #t) #f)) -;; (if (member 'schema options) - ;; (if (eq? run-id 0) - ;; (let ((maindb (db:dbdat-get-db (db:get-db fromdb #f)))) - ;; (db:patch-schema-maindb run-id maindb)) - ;; (db:patch-schema-rundb run-id frundb))) - ;; (set! count (+ count 1)) - ;; (debug:print 0 *default-log-port* "Finished patching schema for " (if (eq? run-id 0) " main.db " (conc run-id ".db")) ", " count " of " total))))) - ;; all-run-ids)) - ;; ;; Then sync and fix db's - ;; (set! count 0) - ;; (process-fork - ;; (lambda () - ;; (map - ;; (lambda (th) - ;; (thread-join! th)) - ;; (map - ;; (lambda (run-id) - ;; (thread-start! - ;; (make-thread - ;; (lambda () - ;; (let* ((fromdb (if toppath (make-dbr:dbstruct path: toppath local: #t) #f)) - ;; (frundb (db:dbdat-get-db (db:get-db fromdb run-id)))) - ;; (if (eq? run-id 0) - ;; (let ((maindb (db:dbdat-get-db (db:get-db fromdb #f)))) -;; (db:sync-tables (db:sync-main-list dbstruct) #f (db:get-db fromdb #f) mtdb) - ;; (set! dead-runs (db:clean-up-maindb (db:get-db fromdb #f)))) - ;; (begin - ;; ;; NB// must sync first to ensure deleted tests get marked as such in megatest.db -;; (db:sync-tables db:sync-tests-only #f (db:get-db fromdb run-id) mtdb) - ;; (db:clean-up-rundb (db:get-db fromdb run-id))))) - ;; (set! count (+ count 1)) - ;; (debug:print 0 *default-log-port* "Finished clean up of " - ;; (if (eq? run-id 0) - ;; " main.db " (conc run-id ".db")) ", " count " of " total))))) - ;; 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) - (stack-push! (dbr:dbstruct-dbstack dbstruct) tmpdb) - data-synced))) + ;; (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)) + + ;; clear out junk records + ;; + ((dejunk) + (db:delay-if-busy mtdb) ;; ok to delay on 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) (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...") @@ -1084,11 +1126,11 @@ ((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)) @@ -1105,31 +1147,36 @@ (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 '', @@ -1137,30 +1184,30 @@ 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 + (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 ( + (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 + (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 ( + (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 '', @@ -1169,11 +1216,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 '', @@ -1180,57 +1227,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 ( + ;; 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 ( + ;; 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, + ;; 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, @@ -1250,18 +1297,18 @@ 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, uname);") - (sqlite3:execute db "CREATE TRIGGER IF NOT EXISTS update_tests_trigger AFTER UPDATE ON tests + (sqlite3:execute db "CREATE INDEX IF NOT EXISTS tests_index ON tests (run_id, testname, item_path, uname);") + (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 + (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', @@ -1268,18 +1315,18 @@ 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 + (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 TABLE IF NOT EXISTS test_data (id INTEGER PRIMARY KEY, test_id INTEGER, category TEXT DEFAULT '', variable TEXT, value REAL, expected REAL, @@ -1288,34 +1335,34 @@ 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 + (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 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)) ;; ) ;;====================================================================== ;; A R C H I V E S ;;====================================================================== @@ -1347,10 +1394,11 @@ "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 ;; @@ -1403,11 +1451,13 @@ res) (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))))) + (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) @@ -1448,11 +1498,11 @@ ;; L O G G I N G D B ;;====================================================================== (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") (string->number (args:get-arg "-override-timeout")) 136000)))) ;; 136000))) (sqlite3:set-busy-handler! db handler) @@ -1491,11 +1541,11 @@ (toplevels '()) (deadtime-str (configf:lookup *configdat* "setup" "deadtime")) (deadtime (if (and deadtime-str (string->number deadtime-str)) (string->number deadtime-str) - 7200))) ;; two hours + 72000))) ;; twenty hours (db:with-db dbstruct #f #f (lambda (db) (if (number? ovr-deadtime)(set! deadtime ovr-deadtime)) @@ -1546,17 +1596,17 @@ ;; 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* ((incompleted '()) (oldlaunched '()) (toplevels '()) - (deadtime-str (configf:lookup *configdat* "setup" "deadtime")) + (deadtime-str (configf:lookup *configdat* "setup" "deadtime")) ;; FIXME suspect test run time & deadtime are not well matched; resulting in COMPLETED/DEAD status of an a-ok running test (deadtime (if (and deadtime-str (string->number deadtime-str)) (string->number deadtime-str) 7200))) ;; two hours (db:with-db @@ -1604,11 +1654,11 @@ ;; ;; (db:delay-if-busy dbdat) (let* (;; (min-incompleted (filter (lambda (x) ;; (let* ((testpath (cadr x)) ;; (tdatpath (conc testpath "/testdat.db")) - ;; (dbexists (file-exists? tdatpath))) + ;; (dbexists (common: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)))) @@ -1615,11 +1665,12 @@ (if (> (length all-ids) 0) (begin (debug:print 0 *default-log-port* "WARNING: Marking test(s); " (string-intersperse (map conc all-ids) ", ") " as INCOMPLETE") (for-each (lambda (test-id) - (db:test-set-state-status dbstruct run-id test-id "COMPLETED" "DEAD" "Test failed to complete")) ;; fix for one aspect of Randy's ticket 1405717332 + (db:test-set-state-status dbstruct run-id test-id "COMPLETED" "DEAD" "Test failed to complete")) ;; fix for one aspect of Randy's ticket 1405717332 ;; TODO - fix problem where test goes to COMPLETED/DEAD while in progress, only later to go to COMPLETED/PASS. ref ticket 220546828 + all-ids)))))))) ;; ALL REPLACED BY THE BLOCK ABOVE ;; ;; (sqlite3:execute @@ -1671,10 +1722,14 @@ "DELETE FROM tests WHERE run_id NOT IN (SELECT DISTINCT id FROM runs);" ;; delete all runs that are state='deleted' "DELETE FROM runs WHERE state='deleted';" ;; 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);" + ;; remove orphaned test_rundat entries + "DELETE FROM test_rundat where test_id NOT IN (SELECT id FROM tests);" + ;; + "DELETE FROM test_steps WHERE test_id NOT IN (SELECT id FROM tests);" )))) ;; (db:delay-if-busy dbdat) (sqlite3:with-transaction db (lambda () @@ -1822,10 +1877,87 @@ (define (db:del-var dbstruct var) (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 (make-busy-timeout 136000)) + (if (not db-exists) + (begin + (sqlite3:execute db "PRAGMA synchronous = 0;") + (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;"))) + db)) + +;; 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 var default) + (let ((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) + (db:safely-close-sqlite3-db db)) + +;; 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))) + (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 @@ -1848,14 +1980,19 @@ ;; 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) + #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)) @@ -1862,10 +1999,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 @@ -1992,10 +2153,48 @@ 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) + (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' 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)) ;; (configf:lookup *configdat* "setup" "dbdir")) (alldbs (glob (conc dbdir "/[0-9]*.db"))) @@ -2052,10 +2251,45 @@ (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 ) + (debug:print-info 11 *default-log-port* "db:get-num-runs START " runpatt) +; (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 @@ -2259,18 +2493,19 @@ (remfields (list "id" "runname" "state" "status" "owner" "event_time" "comment" "fail_count" "pass_count" "contour")) ;; "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: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=? AND state != 'deleted';") + (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))) @@ -2351,11 +2586,11 @@ (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 key-val) res))) + (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 @@ -2369,11 +2604,11 @@ (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))) + (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))) @@ -2680,11 +2915,11 @@ (lambda (db) (sqlite3:first-result db ;; WARNING BUG EDIT ME - merged from v1.55 - not sure what is right here ... ;; "SELECT count(id) FROM tests WHERE state in ('RUNNING','LAUNCHED','REMOTEHOSTSTART') AND run_id NOT IN (SELECT id FROM runs WHERE state='deleted') AND NOT (uname = 'n/a' AND item_path = '');") - "SELECT count(id) FROM tests WHERE state in ('RUNNING','REMOTEHOSTSTART') AND run_id=?;" + "SELECT count(id) FROM tests WHERE state in ('RUNNING','REMOTEHOSTSTART','LAUNCHED') AND run_id=?;" run-id)))) ;; NOT IN (SELECT id FROM runs WHERE state='deleted');") ;; NEW BEHAVIOR: Look only at single run with run-id ;; ;; (define (db:get-running-stats dbstruct run-id) @@ -2694,11 +2929,11 @@ run-id #f (lambda (db) (sqlite3:first-result db - "SELECT count(id) FROM tests WHERE state in ('RUNNING','LAUNCHED','REMOTEHOSTSTART') AND run_id=? AND NOT (uname = 'n/a' AND item_path = '');" run-id)))) + "SELECT count(id) FROM tests WHERE state in ('RUNNING','LAUNCHED','REMOTEHOSTSTART') AND run_id=?;" run-id)))) ;; For a given testname how many items are running? Used to determine ;; probability for regenerating html ;; (define (db:get-count-tests-running-for-testname dbstruct run-id testname) @@ -2951,10 +3186,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 ;;====================================================================== @@ -2984,10 +3253,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))) + (sqlite3:for-each-row + (lambda (id test-id stepname state status event-time logfile comment) + (set! res (vector id test-id stepname state status event-time (if (string? logfile) logfile "") comment))) + db + "SELECT id,test_id,stepname,state,status,event_time,logfile,comment 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 @@ -3003,10 +3287,26 @@ (reverse res))))) ;;====================================================================== ;; T E S T D A T A ;;====================================================================== + + (define (db:get-data-info-by-id dbstruct test-data-id) + (db:with-db + dbstruct + #f + #f + (lambda (db) + (let* ((res (vector #f #f #f #f #f #f #f #f #f #f #f))) + (sqlite3:for-each-row + (lambda (id test-id category variable value expected tol units comment status type ) + (set! res (vector id test-id category variable value expected tol units comment status type))) + db + "SELECT id,test_id, category, variable, value, expected, tol, units, comment, status, type FROM test_data WHERE id=? ORDER BY id ASC;" ;; event_time DESC,id ASC; + 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. @@ -3077,12 +3377,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 @@ -3183,10 +3483,25 @@ (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, tdb: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 ;;====================================================================== @@ -3302,20 +3617,24 @@ ;; ;; 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 (db:test-get-id tl-testdat))) + (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 @@ -3325,11 +3644,11 @@ 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)) ;; item-path is used to exclude current state/status of THIS test + (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 (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") @@ -3338,52 +3657,120 @@ state-status-counts))) ;; (non-completes (filter (lambda (x) ;; (not (equal? (dbr:counts-state x) "COMPLETED"))) ;; state-status-counts)) (all-curr-states (common:special-sort ;; worst -> best (sort of) - (delete-duplicates - (cons state (map dbr:counts-state state-status-counts))) - *common:std-states* >)) + (delete-duplicates + (if (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 - (cons status (map dbr:counts-status state-status-counts))) + (if (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 (equal? x "COMPLETED"))) + (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 - ((> (length non-completes) 0) ;; - (car non-completes)) ;; (remove (lambda (x)(equal? "COMPLETED" x)) all-curr-states))) - (else - (car all-curr-states)))) + ((> 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)))) ;; (if (> running 0) ;; "RUNNING" ;; (if (> bad-not-started 0) ;; "COMPLETED" ;; (car all-curr-states)))) - (newstatus (if (> bad-not-started 0) - "CHECK" - (car all-curr-statuses)))) + (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") + ;; (print "bad-not-supported: " bad-not-support " all-curr-states: " all-curr-states " all-curr-statuses: " all-curr-states) ;; " newstate: " newstate " newstatus: " newstatus) ;; NB// Pass the db so it is part of the transaction - (db:test-set-state-status db run-id tl-test-id newstate newstatus #f))))))) + (debug:print 4 *default-log-port* "BB> tl-test-id="tl-test-id" ; "test-name":"item-path"> bad-not-started="bad-not-started" newstate="newstate" newstatus="newstatus" num-non-completes="num-non-completes" non-completes="non-completes "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:get-all-state-status-counts-for-test dbstruct run-id test-name item-path) - (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=? AND testname=? AND item_path != '' AND item_path !=? GROUP BY state,status;" - run-id test-name item-path)))) +;; 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* +(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 @@ -3719,11 +4106,11 @@ exn (begin (debug:print-info 0 *default-log-port* "WARNING: failed to test for existance of " dbfj) (thread-sleep! 1) (db:delay-if-busy count (- count 1))) - (file-exists? dbfj)) + (common:file-exists? dbfj)) (case count ((6) (thread-sleep! 0.2) (db:delay-if-busy count: 5)) ((5) @@ -3894,10 +4281,11 @@ ;; 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 ;; ;; (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)) + ;; 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 @@ -3920,72 +4308,125 @@ ;; (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* ((unmet-pre-reqs '()) - (result '())) - (for-each + (let* ((ref-test-itemized-mode (not (null? (lset-intersection eq? mode '(itemmatch itemwait))))) + (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 ((tests (db:get-tests-for-run-state-status dbstruct run-id waitontest-name)) + + (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 - (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"))) + (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-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 item-path ref-item-path itemmaps))) ;; (equal? ref-item-path item-path))) + (same-itempath (db:compare-itempaths ref-test-name waiton-item-path ref-item-path itemmaps))) ;; (equal? ref-item-path waiton-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)))))) + ;;(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 (equal? item-path "") ;; this is the parent test - is-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 (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 + ((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 is-completed - (or is-ok + ((and waiton-is-completed + (or waiton-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) + (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)) + (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 - (if (not (or parent-waiton-met item-waiton-met)) - (set! result (append (if (null? tests) (list waitontest-name) tests) result))) ;; appends the string if the full record is not available + ;; (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))))) - (if (not ever-seen) - (set! result (append (if (null? tests)(list waitontest-name) tests) result))))) + ((not ever-seen) + (set! result (append (if (null? waiton-tests)(list waitontest-name) waiton-tests) result)))))) waitons) (delete-duplicates result))))) ;;====================================================================== ;; Just for sync, procedures to make sync easy @@ -4083,12 +4524,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))) @@ -4131,10 +4572,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 @@ -147,10 +147,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)) 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,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:)) @@ -19,11 +28,11 @@ (declare (unit dcommon)) (declare (uses megatest-version)) (declare (uses gutils)) (declare (uses db)) -(declare (uses synchash)) +;; (declare (uses synchash)) (include "common_records.scm") (include "db_records.scm") (include "key_records.scm") (include "run_records.scm") @@ -85,185 +94,185 @@ ;; 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 (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: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))) @@ -313,11 +322,12 @@ (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) @@ -333,11 +343,14 @@ ;; 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 (list "PASS" "WARN" "WAIVED" "SKIP" "FAIL" "ABORT" #f)) + ((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) @@ -491,11 +504,11 @@ (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" + ;; #:expand "YES" ;; "HORIZONTAL" #:numcol 1 #:numlin (length key-vals) #:numcol-visible 1 #:numlin-visible (min 10 (length key-vals)) #:scrollbar "YES"))) @@ -1185,11 +1198,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) DELETED defunct/multi-dboard.scm Index: defunct/multi-dboard.scm ================================================================== --- defunct/multi-dboard.scm +++ /dev/null @@ -1,801 +0,0 @@ -;;====================================================================== -;; 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. -;;====================================================================== - -(use format numbers sql-de-lite srfi-1 posix regex regex-case srfi-69 srfi-18 call-with-environment-variables) -(require-library iup) -(import (prefix iup iup:)) -(use canvas-draw) - -(declare (uses margs)) -(declare (uses megatest-version)) -(declare (uses gutils)) -(declare (uses tree)) -(declare (uses configf)) -(declare (uses portlogger)) -(declare (uses keys)) -(declare (uses common)) - -(include "common_records.scm") -;; (include "db_records.scm") -;; (include "key_records.scm") - -(define help (conc - "Megatest Dashboard, documentation at http://www.kiatoa.com/fossils/megatest - version " megatest-version " - license GPL, Copyright (C) Matt Welland 2011 - -Usage: dashboard [options] - -h : this help - -group groupname : display this group of areas - -test testid : control test identified by testid - -guimonitor : control panel for runs - -Misc - -rows N : set number of rows -")) - -;; process args -(define remargs (args:get-args - (argv) - (list "-group" ;; display this group of areas - "-debug" - ) - (list "-h" - "-v" - "-q" - ) - args:arg-hash - 0)) - -(if (args:get-arg "-h") - (begin - (print help) - (exit))) - -;; (if (args:get-arg "-host") -;; (begin -;; (set! (common:get-remote remote) (string-split (args:get-arg "-host" ":"))) -;; (client:launch)) -;; (client:launch)) - -(define *runremote* #f) -(define *windows* (make-hash-table)) -(define *changed-main* (make-hash-table)) ;; set path/... => #t -(define *changed-mutex* (make-mutex)) ;; use for all incoming change requests -(define *searchpatts* (make-hash-table)) - -(debug:setup) - -(define *tim* (iup:timer)) -(define *ord* #f) - -(iup:attribute-set! *tim* "TIME" 300) -(iup:attribute-set! *tim* "RUN" "YES") - -(define (message-window msg) - (iup:show - (iup:dialog - (iup:vbox - (iup:label msg #:margin "40x40"))))) - -(define (iuplistbox-fill-list lb items . default) - (let ((i 1) - (selected-item (if (null? default) #f (car default)))) - (iup:attribute-set! lb "VALUE" (if selected-item selected-item "")) - (for-each (lambda (item) - (iup:attribute-set! lb (number->string i) item) - (if selected-item - (if (equal? selected-item item) - (iup:attribute-set! lb "VALUE" item))) ;; (number->string i)))) - (set! i (+ i 1))) - items) - i)) - -(define (pad-list l n)(append l (make-list (- n (length l))))) - - -(define (mkstr . x) - (string-intersperse (map conc x) ",")) - -(define (update-search x val) - (hash-table-set! *searchpatts* x val)) - - -;;====================================================================== -;; R E C O R D S -;;====================================================================== - -;; NOTE: Consider switching to defstruct. - -;; data for an area (regression or testsuite) -;; -(define-record areadat - name ;; area name - path ;; mt run area home - configdat ;; megatest config - denoise ;; focal point for not putting out same messages over and over - client-signature ;; key for client-server conversation - remote ;; hash of all the client side connnections - run-keys ;; target keys for this area - runs ;; used in dashboard, hash of run-ids -> rundat - read-only ;; can I write to this area? - monitordb ;; db handle for monitor.db - maindb ;; db handle for main.db - ) - -;; rundat, basic run data -;; -(define-record rundat - id ;; the run-id - target ;; val1/val2 ... corrosponding to run-keys in areadat - runname - state ;; state of the run, symbol - status ;; status of the run, symbol - event-time ;; when the run was initiated - tests ;; hash of test-id -> testdat, QUESTION: separate by run-id? - db ;; db handle - ) - -;; testdat, basic test data -(define-record testdat - run-id ;; what run is this from - id ;; test id - testname ;; test name - itempath ;; item path - state ;; test state, symbol - status ;; test status, symbol - event-time ;; when the test started - duration ;; how long the test took - ) - -;; general data for the dboard application -;; -(define-record data - cfgdat ;; data from ~/.megatest/.dat - areas ;; hash of areaname -> area-rec - current-window-id ;; - current-tab-id ;; - update-needed ;; flag to indicate that the tab pointed to by current tab id needs refreshing immediately - tabs ;; hash of tab-id -> areaname (??) should be of type "tab" - ) - -;; all the components of an area display, all fits into a tab but -;; parts may be swapped in/out as needed -;; -(define-record tab - tree - matrix ;; the spreadsheet - areadat ;; the one-structure (one day dbstruct will be put in here) - view-path ;; //... - view-type ;; standard, etc. - controls ;; the controls - data ;; all the data kept in sync with db - filters ;; user filters, alist name -> filter record, eventually store these in ~/.megatest/.dat? - run-id ;; the current run-id - test-ids ;; the current test id hash, run-id => test-id - command ;; the command from the entry field - headers ;; hash of header -> colnum - rows ;; hash of rowname -> rownum - ) - -(define-record filter - target ;; hash of widgets for the target - runname ;; the runname widget - testpatt ;; the testpatt widget - ) - -;;====================================================================== -;; D B -;;====================================================================== - -;; These are all using sql-de-lite and independent of area so cannot use stuff -;; from db.scm - -;; NB// run-id=#f => return dbdir only -;; -(define (areadb:dbfile-path areadat run-id) - (let* ((cfgdat (areadat-configdat areadat)) - (dbdir (or (configf:lookup cfgdat "setup" "dbdir") - (conc (configf:lookup cfgdat "setup" "linktree") "/.db"))) - (fname (if run-id - (case run-id - ((-1) "monitor.db") - ((0) "main.db") - (else (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))) - -;; -1 => monitor.db -;; 0 => main.db -;; >1 => .db -;; -(define (areadb:open areadat run-id) - (let* ((runs (areadat-runs areadat)) - (rundat (if (> run-id 0) ;; it is a run - (hash-table-ref/default runs run-id #f) - #f)) - (db (case run-id ;; if already opened, get the db and return it - ((-1) (areadat-monitordb areadat)) - ((0) (areadat-maindb areadat)) - (else (if rundat - (rundat-db rundat) - #f))))) - (if db - db ;; merely return the already opened db - (let* ((dbfile (areadb:dbfile-path areadat run-id)) ;; not already opened, so open it - (db (if (file-exists? dbfile) - (open-database dbfile) - (begin - (debug:print-error 0 *default-log-port* "I was asked to open " dbfile ", but file does not exist or is not readable.") - #f)))) - (case run-id - ((-1)(areadat-monitordb-set! areadat db)) - ((0) (areadat-maindb-set! areadat db)) - (else (rundat-db-set! rundat db))) - db)))) - -;; populate the areadat tests info, does NOT fill the tests data itself unless asked -;; -(define (areadb:populate-run-info areadat) - (let* ((runs (or (areadat-runs areadat) (make-hash-table))) - (keys (areadat-run-keys areadat)) - (maindb (areadb:open areadat 0))) - (if maindb - (query (for-each-row (lambda (row) - (let ((id (list-ref row 0)) - (dat (apply make-rundat (append row (list #f #f))))) ;; add placeholders for tests and db - (print row) - (hash-table-set! runs id dat)))) - (sql maindb (conc "SELECT id," - (string-intersperse keys "||'/'||") - ",runname,state,status,event_time FROM runs WHERE state != 'deleted';"))) - (debug:print-error 0 *default-log-port* "no main.db found at " (areadb:dbfile-path areadat 0))) - areadat)) - -;; given an areadat and target/runname patt fill up runs data -;; -;; ?????/ - -;; given a list of run-ids refresh/retrieve runs data into areadat -;; -(define (areadb:fill-tests areadat #!key (run-ids #f)) - (let* ((runs (or (areadat-runs areadat) (make-hash-table)))) - (for-each - (lambda (run-id) - (let* ((rundat (hash-table-ref/default runs run-id #f)) - (tests (if (and rundat - (rundat-tests rundat)) ;; re-use existing hash table? - (rundat-tests rundat) - (let ((ht (make-hash-table))) - (rundat-tests-set! rundat ht) - ht))) - (rundb (areadb:open areadat run-id))) - (query (for-each-row (lambda (row) - (let* ((id (list-ref row 0)) - (testname (list-ref row 1)) - (itempath (list-ref row 2)) - (state (list-ref row 3)) - (status (list-ref row 4)) - (eventtim (list-ref row 5)) - (duration (list-ref row 6))) - (hash-table-set! tests id - (make-testdat run-id id testname itempath state status eventtim duration))))) - (sql rundb "SELECT id,testname,item_path,state,status,event_time,run_duration FROM tests WHERE state != 'DELETED';")))) - (or run-ids (hash-table-keys runs))) - areadat)) - - -;; initialize and refresh data -;; -(define (dboard:general-updater con port) - (for-each - (lambda (window-id) - ;; (print "Processing for window-id " window-id) - (let* ((window-dat (hash-table-ref *windows* window-id)) - (areas (data-areas window-dat)) - ;; (keys (areadat-run-keys area-dat)) - (tabs (data-tabs window-dat)) - (tab-ids (hash-table-keys tabs)) - (current-tab (if (null? tab-ids) - #f - (hash-table-ref tabs (car tab-ids)))) - (current-tree (if (null? tab-ids) #f (tab-tree current-tab))) - (current-node (if (null? tab-ids) 0 (string->number (iup:attribute current-tree "VALUE")))) - (current-path (if (eq? current-node 0) - "Areas" - (string-intersperse (tree:node->path current-tree current-node) "/"))) - (current-matrix (if (null? tab-ids) #f (tab-matrix current-tab))) - (seen-nodes (make-hash-table)) - (path-changed (if current-tab - (equal? current-path (tab-view-path current-tab)) - #t))) - ;; (debug:print-info 0 *default-log-port* "Current path: " current-path) - ;; now for each area in the window gather the data - (if path-changed - (begin - (debug:print-info 0 *default-log-port* "clearing matrix - path changed") - (dboard:clear-matrix current-tab))) - (for-each - (lambda (area-name) - ;; (print "Processing for area-name " area-name) - (let* ((area-dat (hash-table-ref areas area-name)) - (area-path (areadat-path area-dat)) - (runs (areadat-runs area-dat))) - (if (hash-table-ref/default *changed-main* area-path 'processed) - (begin - (print "Processing " area-dat " for area-name " area-name) - (hash-table-set! *changed-main* area-path #f) - (areadb:populate-run-info area-dat) - (for-each - (lambda (run-id) - (let* ((run (hash-table-ref runs run-id)) - (target (rundat-target run)) - (runname (rundat-runname run))) - (if current-tree - (let* ((partial-path (append (string-split target "/")(list runname))) - (full-path (cons area-name partial-path))) - (if (not (hash-table-exists? seen-nodes full-path)) - (begin - (print "INFO: Adding node " partial-path " to section " area-name) - (tree:add-node current-tree "Areas" full-path) - (areadb:fill-tests area-dat run-ids: (list run-id)))) - (hash-table-set! seen-nodes full-path #t))))) - (hash-table-keys runs)))) - (if (or (equal? "Areas" current-path) - (string-match (conc "^Areas/" area-name "(|\\/.*)$") current-path)) - (dboard:redraw-area area-name area-dat current-tab current-matrix current-path)))) - (hash-table-keys areas)))) - (hash-table-keys *windows*))) - -;;====================================================================== -;; D A S H B O A R D D B -;;====================================================================== - -;; All moved to common.scm - -;;====================================================================== -;; T R E E -;;====================================================================== - -;; - - - - - -(define (dashboard:tree-browser data adat window-id) - ;; (iup:split - (let* ((tb (iup:treebox - #:value 0 - #:title "Areas" - #:expand "YES" - #:addexpanded "NO" - #:selection-cb - (lambda (obj id state) - ;; (print "obj: " obj ", id: " id ", state: " state) - (let* ((tree-path (tree:node->path obj id)) - (area (car tree-path)) - (areadat-path (cdr tree-path))) - #f - ;; (test-id (tree-path->test-id (cdr run-path)))) - ;; (if test-id - ;; (hash-table-set! (dboard:data-curr-test-ids *data*) - ;; window-id test-id)) - ;; (print "path: " (tree:node->path obj id) " test-id: " test-id)))))) - ))))) - ;; (iup:attribute-set! tb "VALUE" "0") - ;; (iup:attribute-set! tb "NAME" "Runs") - ;; (iup:attribute-set! tb "ADDEXPANDED" "NO") - ;; (dboard:data-tests-tree-set! *data* tb) - tb)) - -;;====================================================================== -;; M A I N M A T R I X -;;====================================================================== - -;; General displayer -;; -(define (dashboard:main-matrix data adat window-id) - (let* (;; (tab-dat (areadat- - (view-matrix (iup:matrix - ;; (runs-for-targ (db:get-runs-by-patt *dbstruct-local* *keys* "%" target #f #f #f)) - #:expand "YES" - ;; #:fittosize "YES" - #:resizematrix "YES" - #:scrollbar "YES" - #:numcol 100 - #:numlin 100 - #:numcol-visible 3 - #:numlin-visible 20 - #:click-cb (lambda (obj lin col status) - (print "obj: " obj " lin: " lin " col: " col " status: " status " value: " (iup:attribute obj "VALUE")))))) - - ;; (iup:attribute-set! view-matrix "RESIZEMATRIX" "YES") - (iup:attribute-set! view-matrix "WIDTH0" "100") - ;; (dboard:data-runs-matrix-set! *data* runs-matrix) - ;; (iup:hbox - ;; (iup:frame - ;; #:title "Runs browser" - ;; (iup:vbox - view-matrix)) - -;;====================================================================== -;; A R E A S -;;====================================================================== - -(define (dashboard:init-area data area-name apath) - (let* ((mtconf (dboard:read-mtconf apath)) - (area-dat (let ((ad (make-areadat - area-name ;; area name - apath ;; path to area - ;; 'http ;; transport - mtconf ;; megatest.config - (make-hash-table) ;; denoise hash - #f ;; client-signature - #f ;; remote connections - (keys:config-get-fields mtconf) ;; run keys - (make-hash-table) ;; run-id -> (hash of test-ids => dat) - (and (file-exists? apath)(file-write-access? apath)) ;; read-only - #f - #f - ))) - (hash-table-set! (data-areas data) area-name ad) - ad))) - area-dat)) - -;; given the keys for an area and a path from the tree browser -;; return the level: areas area runs run tests test -;; -(define (dboard:get-view-type keys current-path) - (let* ((path-parts (string-split current-path "/")) - (path-len (length path-parts))) - (cond - ((equal? current-path "Areas") 'areas) - ((eq? path-len 2) 'area) - ((<= (+ (length keys) 2) path-len) 'runs) - (else 'run)))) - -(define (dboard:clear-matrix tab) - (if tab - (begin - (iup:attribute-set! (tab-matrix tab) "CLEARVALUE" "ALL") - (tab-headers-set! tab (make-hash-table)) - (tab-rows-set! tab (make-hash-table))))) - -;; full redraw of a given area -;; -(define (dboard:redraw-area area-name area-dat tab-dat current-matrix current-path) - (let* ((keys (areadat-run-keys area-dat)) - (runs (areadat-runs area-dat)) - (headers (tab-headers tab-dat)) - (rows (tab-rows tab-dat)) - (used-cols (hash-table-values headers)) - (used-rows (hash-table-values rows)) - (touched (make-hash-table)) ;; (vector row col) ==> true, touched cell - (view-type (dboard:get-view-type keys current-path)) - (changed #f) - (state-statuses (list "PASS" "FAIL" "WARN" "CHECK" "SKIP" "RUNNING" "LAUNCHED"))) - ;; (debug:print 0 *default-log-port* "current-matrix=" current-matrix) - (case view-type - ((areas) ;; find row for this area, if not found, create new entry - (let* ((curr-rownum (hash-table-ref/default rows area-name #f)) - (next-rownum (+ (apply max (cons 0 used-rows)) 1)) - (rownum (or curr-rownum next-rownum)) - (coord (conc rownum ":0"))) - (if (not curr-rownum)(hash-table-set! rows area-name rownum)) - (if (not (equal? (iup:attribute current-matrix coord) area-name)) - (begin - (let loop ((hed (car state-statuses)) - (tal (cdr state-statuses)) - (count 1)) - (if (not (equal? (iup:attribute current-matrix (conc "0:" count)) hed)) - (iup:attribute-set! current-matrix (conc "0:" count) hed)) - (iup:attribute-set! current-matrix (conc rownum ":" count) "0") - (if (not (null? tal)) - (loop (car tal)(cdr tal)(+ count 1)))) - (debug:print-info 0 *default-log-port* "view-type=" view-type ", rownum=" rownum ", curr-rownum=" curr-rownum ", next-rownum=" next-rownum ", coord=" coord ", area-name=" area-name) - (iup:attribute-set! current-matrix coord area-name) - (set! changed #t)))))) - (if changed (iup:attribute-set! current-matrix "REDRAW" "ALL")))) - - - - ;; (dboard:clear-matrix current-matrix used-cols used-rows touched) ;; clear all - - - -;;====================================================================== -;; D A S H B O A R D -;;====================================================================== - -(define (dashboard:area-panel aname data window-id) - (let* ((apath (configf:lookup (data-cfgdat data) aname "path")) ;; (hash-table-ref (dboard:data-cfgdat data) area-name)) - ;; (hash-table-ref (dboard:data-cfgdat data) aname)) - (area-dat (dashboard:init-area data aname apath)) - (tb (dashboard:tree-browser data area-dat window-id)) ;; (dboard:areas-tree-browser data) - (ad (dashboard:main-matrix data area-dat window-id)) - (areas (data-areas data)) - (dboard-dat (make-tab - #f ;; tree - #f ;; matrix - area-dat ;; - #f ;; view path - 'default ;; view type - #f ;; controls - (make-hash-table) ;; cached data? not sure how to use this yet :) - #f ;; filters - #f ;; the run-id - (make-hash-table) ;; run-id -> test-id, for current test id - "" - (make-hash-table) ;; headername -> colnum - (make-hash-table) ;; rowname -> rownum - ))) - (hash-table-set! (data-areas data) aname area-dat) ;; dboard-dat) - (hash-table-set! (data-tabs data) window-id dboard-dat) - (tab-tree-set! dboard-dat tb) - (tab-matrix-set! dboard-dat ad) - (iup:split - #:value 200 - tb ad))) - - -;; Main Panel -;; -(define (dashboard:main-panel data window-id) - (iup:dialog - #:title "Megatest Control Panel" -;; #:menu (dcommon:main-menu data) - #:shrink "YES" - (iup:vbox - (let* ((area-names (hash-table-keys (data-cfgdat data))) - (area-panels (map (lambda (aname) - (dashboard:area-panel aname data window-id)) - area-names)) - (tabtop (apply iup:tabs - #:tabchangepos-cb (lambda (obj curr prev) - (data-current-tab-id-set! data curr) - (data-update-needed-set! data #t) - (print "Tab is: " curr ", prev was " prev)) - area-panels)) - (tabs (data-tabs data))) - (if (not (null? area-names)) - (let loop ((index 0) - (hed (car area-names)) - (tal (cdr area-names))) - ;; (hash-table-set! tabs index hed) - (debug:print 0 *default-log-port* "Adding area " hed " with index " index " to dashboard") - (iup:attribute-set! tabtop (conc "TABTITLE" index) hed) - (if (not (null? tal)) - (loop (+ index 1)(car tal)(cdr tal))))) - tabtop)))) - - -;;====================================================================== -;; N A N O M S G S E R V E R -;;====================================================================== - -(define (dboard:server-service soc port) - (print "server starting") - (let loop ((msg-in (nn-recv soc)) - (count 0)) - (if (eq? 0 (modulo count 1000)) - (print "server received: " msg-in ", count=" count)) - (cond - ;; - ;; quit - ;; - ((equal? msg-in "quit") - (nn-send soc "Ok, quitting")) - ;; - ;; ping - ;; - ((and (>= (string-length msg-in) 4) - (equal? (substring msg-in 0 4) "ping")) - (nn-send soc (conc (current-process-id))) - (loop (nn-recv soc)(+ count 1))) - ;; - ;; main changed - ;; - ((and (>= (string-length msg-in) 4) - (equal? (substring msg-in 0 4) "main")) - (let ((parts (string-split msg-in " "))) - (hash-table-set! *changed-main* (cadr parts) #t) - (nn-send soc "got it!"))) - ;; - ;; ?? - ;; - (else - (nn-send soc "hello " msg-in " you got to the else clause!"))) - (loop (nn-recv soc)(if (> count 20000000) - 0 - (+ count 1))))) - -(define (dboard:one-time-ping-receive soc port) - (let ((msg-in (nn-recv soc))) - (if (and (>= (string-length msg-in) 4) - (equal? (substring msg-in 0 4) "ping")) - (nn-send soc (conc (current-process-id)))))) - -(define (dboard:server-start given-port #!key (num-tries 200)) - (let* ((rep (nn-socket 'rep)) - (port (or given-port (portlogger:main "find"))) - (con (conc "tcp://*:" port))) - ;; register this connect here .... - (nn-bind rep con) - (thread-start! - (make-thread (lambda () - (dboard:one-time-ping-receive rep port)) - "one time receive thread")) - (if (dboard:ping-self "localhost" port) - (begin - (print "INFO: dashboard nanomsg server started on " port) - (values rep port)) - (begin - (print "WARNING: couldn't create server on port " port) - (portlogger:main "set" "failed") - (if (> num-tries 0) - (dboard:server-start #f (- num-tries 1)) - (begin - (print "ERROR: failed to start nanomsg server") - (values #f #f))))))) - -(define (dboard:server-close con port) - (nn-close con) - (portlogger:main "set" port "released")) - -(define (dboard:ping-self host port #!key (return-socket #t)) - ;; send a random number along with pid and check that we get it back - (let* ((req (nn-socket 'req)) - (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"))) - (nn-connect req (conc "tcp://" host ":" port)) - (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 " host ":" port)) - (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)))) - -;;====================================================================== -;; C O N F I G U R A T I O N -;;====================================================================== - -;; Get the configuration file for a group name, if the group name is "default" and it doesn't -;; exist, create it and add the current path if it contains megatest.config -;; -(define (dboard:get-config group-name) - (let* ((fname (conc (getenv "HOME") "/.megatest/" group-name ".dat"))) - (if (file-exists? fname) - (read-config fname (make-hash-table) #t) - (if (dboard:create-config fname) - (dboard:get-config group-name) - (make-hash-table))))) - -(define (dboard:create-config fname) - ;; (handle-exceptions - ;; exn - ;; - ;; #f ;; failed to create - just give up - (let* ((dirname (pathname-directory fname)) - (file-name (pathname-strip-directory fname)) - (curr-mtcfgdat (find-config "megatest.config" - toppath: (or (get-environment-variable "MT_RUN_AREA_HOME")(current-directory)))) - (curr-mtcfg (if (and curr-mtcfgdat (not (null? curr-mtcfgdat)))(cadr curr-mtcfgdat) #f)) - (curr-mtpath (if curr-mtcfg (car curr-mtcfgdat) #f))) - (if curr-mtpath - (begin - (debug:print-info 0 *default-log-port* "Creating config file " fname) - (if (not (file-exists? dirname)) - (create-directory dirname #t)) - (with-output-to-file fname - (lambda () - (let ((aname (pathname-strip-directory curr-mtpath))) - (print "[" aname "]") - (print "path " curr-mtpath)))) - #t) - (begin - (debug:print-info 0 *default-log-port* "Need to create a config but no megatest.config found: " curr-mtcfgdat) - #f)))) -;; ) - -(define (dboard:read-mtconf apath) - (let* ((mtconffile (conc apath "/megatest.config"))) - (call-with-environment-variables - (list (cons "MT_RUN_AREA_HOME" apath)) - (lambda () - (read-config mtconffile (make-hash-table) #f)) ;; megatest.config - ))) - - -;;====================================================================== -;; G U I S T U F F -;;====================================================================== - -;;; main. Theoretically could have multiple windows (each with a group of tags, thus window-id -;;; -(define (dboard:make-window window-id) - (let* (;; (window-id 0) - (groupn (or (args:get-arg "-group") "default")) - (cfgdat (dboard:get-config groupn)) - ;; (cfgdat (if (file-exists? cfname)(read-config cfname (make-hash-table) #t)(make-hash-table))) - (data (make-data - cfgdat ;; this is the data from ~/.megatest for the selected group - (make-hash-table) ;; areaname -> area-rec - 0 ;; current window id - 0 ;; current tab id - #f ;; redraw needed for current tab id - (make-hash-table) ;; tab-id -> areaname - ))) - (hash-table-set! *windows* window-id data) - (iup:show (dashboard:main-panel data window-id)) - (iup:main-loop))) - -;; ease debugging by loading ~/.dashboardrc -(let ((debugcontrolf (conc (get-environment-variable "HOME") "/.dashboardrc"))) - (if (file-exists? debugcontrolf) - (load debugcontrolf))) - -(define (main) - (let-values - (((con port)(dboard:server-start #f))) - (let ((portnum (if (string? port)(string->number port) port))) - ;; got here, monitor/dashboard was started - (mddb:register-dashboard portnum) - (thread-start! (make-thread (lambda ()(dboard:server-service con portnum)) "server service")) - (thread-start! (make-thread (lambda () - (let loop () - (dboard:general-updater con portnum) - (thread-sleep! 1) - (loop))) "general updater")) - (dboard:make-window 0) - (mddb:unregister-dashboard (get-host-name) portnum) - (dboard:server-close con port)))) - DELETED defunct/nmsg-transport.scm Index: defunct/nmsg-transport.scm ================================================================== --- defunct/nmsg-transport.scm +++ /dev/null @@ -1,358 +0,0 @@ - -;; 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 program is distributed WITHOUT ANY WARRANTY; without even the -;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR -;; PURPOSE. - -(require-extension (srfi 18) extras tcp s11n) - -(use sqlite3 srfi-1 posix regex regex-case srfi-69 hostinfo md5 message-digest) -(import (prefix sqlite3 sqlite3:)) - -;; (use nanomsg) - -(declare (unit nmsg-transport)) - -(declare (uses common)) -(declare (uses db)) -(declare (uses tests)) -(declare (uses tasks)) ;; tasks are where stuff is maintained about what is running. -(declare (uses server)) - -(include "common_records.scm") -(include "db_records.scm") - -;; Transition to pub --> sub with pull <-- push -;; -;; 1. client sends request to server via push to the pull port -;; 2. server puts request in queue or processes immediately as appropriate -;; 3. server puts responses from completed requests into pub port -;; -;; TODO -;; -;; Done Tested -;; [x] [ ] 1. Add columns pullport pubport to servers table -;; [x] [ ] 2. Add rm of monitor.db if older than 11/12/2012 -;; [x] [ ] 3. Add create of pullport and pubport with finding of available ports -;; [x] [ ] 4. Add client compose of request -;; [x] [ ] - name of client: testname/itempath-test_id-hostname -;; [x] [ ] - name of request: callname, params -;; [x] [ ] - request key: f(clientname, callname, params) -;; [x] [ ] 5. Add processing of subscription hits -;; [x] [ ] - done when get key -;; [x] [ ] - return results -;; [x] [ ] 6. Add timeout processing -;; [x] [ ] - after 60 seconds -;; [ ] [ ] i. check server alive, connect to new if necessary -;; [ ] [ ] ii. resend request -;; [ ] [ ] 7. Turn self ping back on - -(define (nmsg-transport:make-server-url hostport #!key (bindall #f)) - (if (not hostport) - #f - (conc "tcp://" (if bindall "*" (car hostport)) ":" (cadr hostport)))) - -(define *server-loop-heart-beat* (current-seconds)) -(define *heartbeat-mutex* (make-mutex)) - -;;====================================================================== -;; S E R V E R -;;====================================================================== - -(define (nmsg-transport:run dbstruct hostn run-id server-id #!key (retrynum 1000)) - (debug:print 2 *default-log-port* "Attempting to start the server ...") - (let* ((start-port (portlogger:open-run-close portlogger:find-port)) - (server-thread (make-thread (lambda () - (nmsg-transport:try-start-server dbstruct run-id start-port server-id)) - "server thread")) - (tdbdat (tasks:open-db))) - (thread-start! server-thread) - (thread-sleep! 0.1) - (if (nmsg-transport:ping hostn start-port timeout: 2 expected-key: (current-process-id)) - (let ((interface (if (equal? hostn "-")(get-host-name) hostn))) - (tasks:server-set-interface-port (db:delay-if-busy tdbdat) server-id interface start-port) - (tasks:server-set-state! (db:delay-if-busy tdbdat) server-id "dbprep") - (set! *server-info* (list hostn start-port)) ;; probably not needed anymore? currently used by keep-running - (thread-sleep! 3) ;; give some margin for queries to complete before switching from file based access to server based access - ;; (set! *inmemdb* dbstruct) - (tasks:server-set-state! (db:delay-if-busy tdbdat) server-id "running") - (thread-start! (make-thread - (lambda ()(nmsg-transport:keep-running server-id run-id)) - "keep running")) - (thread-join! server-thread)) - (if (> retrynum 0) - (begin - (debug:print 0 *default-log-port* "WARNING: Failed to connect to server (self) on host " hostn ":" start-port ", trying again.") - (tasks:server-delete-record (db:delay-if-busy tdbdat) server-id "failed to start, never received server alive signature") - (portlogger:open-run-close portlogger:set-failed start-port) - (nmsg-transport:run dbstruct hostn run-id server-id)) - (begin - (debug:print-error 0 *default-log-port* "could not find an open port to start server on. Giving up") - (exit 1)))))) - -(define (nmsg-transport:try-start-server dbstruct run-id portnum server-id) - (let ((repsoc (nn-socket 'rep))) - (nn-bind repsoc (conc "tcp://*:" portnum)) - (let loop ((msg-in (nn-recv repsoc))) - (let* ((dat (db:string->obj msg-in transport: 'nmsg))) - (debug:print 0 *default-log-port* "server, received: " dat) - (let ((result (api:execute-requests dbstruct dat))) - (debug:print 0 *default-log-port* "server, sending: " result) - (nn-send repsoc (db:obj->string result transport: 'nmsg))) - (loop (nn-recv repsoc)))))) - -;; all routes though here end in exit ... -;; -(define (nmsg-transport:launch run-id) - (let* ((tdbdat (tasks:open-db)) - (dbstruct (db:setup run-id)) - (hostn (or (args:get-arg "-server") "-"))) - (set! *run-id* run-id) - (set! *inmemdb* dbstruct) - ;; with nbfake daemonize isn't really needed - ;; - ;; (if (args:get-arg "-daemonize") - ;; (begin - ;; (daemon:ize) - ;; (if *alt-log-file* ;; we should re-connect to this port, I think daemon:ize disrupts it - ;; (begin - ;; (current-error-port *alt-log-file*) - ;; (current-output-port *alt-log-file*))))) - (if (server:check-if-running run-id) - (begin - (debug:print-info 0 *default-log-port* "Server for run-id " run-id " already running") - (exit 0))) - (let loop ((server-id (tasks:server-lock-slot (db:delay-if-busy tdbdat) run-id)) - (remtries 4)) - (if (not server-id) - (if (> remtries 0) - (begin - (thread-sleep! 2) - (if (not (server:check-if-running run-id)) - (loop (tasks:server-lock-slot (db:delay-if-busy tdbdat) run-id) - (- remtries 1)) - (begin - (debug:print-info 0 *default-log-port* "Another server took the slot, exiting") - (exit 0)))) - (begin - ;; since we didn't get the server lock we are going to clean up and bail out - (debug:print-info 2 *default-log-port* "INFO: server pid=" (current-process-id) ", hostname=" (get-host-name) " not starting due to other candidates ahead in start queue") - (tasks:server-delete-records-for-this-pid (db:delay-if-busy tdbdat) " http-transport:launch") - )) - ;; locked in a server id, try to start up - (nmsg-transport:run dbstruct hostn run-id server-id)) - (set! *didsomething* #t) - (exit)))) - -;;====================================================================== -;; S E R V E R U T I L I T I E S -;;====================================================================== - -(define (nmsg-transport:mk-signature) - (message-digest-string (md5-primitive) - (with-output-to-string - (lambda () - (write (list (current-directory) - (argv))))))) - -;;====================================================================== -;; C L I E N T S -;;====================================================================== - -;; ping the server at host:port -;; return the open socket if successful (return-socket == #t) -;; expect the key expected-key returned in payload -;; send our-key or #f as payload -;; -(define (nmsg-transport:ping hostn port #!key (timeout 3)(return-socket #t)(expected-key #f)(our-key #f)(socket #f)) - ;; send a random number along with pid and check that we get it back - (let* ((host (if (or (not hostn) - (equal? hostn "-")) ;; use localhost - (get-host-name) - hostn)) - (req (or socket - (let ((soc (nn-socket 'req))) - (nn-connect soc (conc "tcp://" host ":" port)) - soc))) - (success #t) - (dat (vector "ping" our-key)) - (result (condition-case - (nmsg-transport:client-api-send-receive-raw req dat timeout: timeout) - ((timeout)(set! success #f) #f))) - (key (if success - (vector-ref result 1) - #f))) - (debug:print 0 *default-log-port* "success=" success ", key=" key ", expected-key=" expected-key ", equal? " (equal? key expected-key)) - (if (and success - (or (not expected-key) ;; just getting a reply is good enough then - (equal? key expected-key))) - (if return-socket - req - (begin - (if (not socket)(nn-close req)) ;; don't want a side effect of closing socket if handed it - #t)) - (begin - (if (not socket)(nn-close req)) ;; failed to ping, close socket as side effect - #f)))) - -;; send data to server, wait max of timeout seconds for a response. -;; return #( success/fail result ) -;; -;; for effiency it is easier to do the obj->string and string->obj here. -;; -(define (nmsg-transport:client-api-send-receive-raw socreq indat #!key (enable-send #t)(timeout 25)) - (let* ((success #f) - (result #f) - (keepwaiting #t) - (dat (db:obj->string indat transport: 'nmsg)) - (send-recv (make-thread - (lambda () - (nn-send socreq dat) - (let* ((res (nn-recv socreq))) - (set! success #t) - (set! result (db:string->obj res transport: 'nmsg)))) - "send-recv")) - (timeout (make-thread - (lambda () - (let loop ((count 0)) - (thread-sleep! 1) - (debug:print-info 1 *default-log-port* "send-receive-raw, still waiting after " count " seconds...") - (if (and keepwaiting (< count timeout)) ;; yes, this is very aproximate - (loop (+ count 1)))) - (if keepwaiting - (begin - (print "timeout waiting for ping") - (thread-terminate! send-recv)))) - "timeout"))) - ;; replace with condition-case? - (handle-exceptions - exn - (set! result "timeout") - (thread-start! timeout) - (thread-start! send-recv) - (thread-join! send-recv) - (if success (thread-terminate! timeout))) - ;; raise timeout error if timed out - (if success - (if (and (vector? result) - (vector-ref result 0)) ;; did it fail at the server? - result ;; nope, all good - (begin - (debug:print-error 0 *default-log-port* "error occured at server, info=" (vector-ref result 2)) - (debug:print 0 *default-log-port* " client call chain:") - (print-call-chain (current-error-port)) - (debug:print 0 *default-log-port* " server call chain:") - (pp (vector-ref result 1) (current-error-port)) - (signal (vector-ref result 0)))) - (signal (make-composite-condition - (make-property-condition 'timeout 'message "nmsg-transport:client-api-send-receive-raw timed out talking to server")))))) - -;; run nmsg-transport:keep-running in a parallel thread to monitor that the db is being -;; used and to shutdown after sometime if it is not. -;; -(define (nmsg-transport:keep-running server-id run-id) - ;; if none running or if > 20 seconds since - ;; server last used then start shutdown - ;; This thread waits for the server to come alive - (let* ((server-info (let loop () - (let ((sdat #f)) - (mutex-lock! *heartbeat-mutex*) - (set! sdat *server-info*) - (mutex-unlock! *heartbeat-mutex*) - (if sdat - (begin - (debug:print-info 0 *default-log-port* "keep-running got sdat=" sdat) - sdat) - (begin - (thread-sleep! 0.5) - (loop)))))) - (iface (car server-info)) - (port (cadr server-info)) - (last-access 0) - (tdbdat (tasks:open-db)) - (server-timeout (let ((tmo (configf:lookup *configdat* "server" "timeout"))) - (if (and (string? tmo) - (string->number tmo)) - (* 60 60 (string->number tmo)) - ;; (* 3 24 60 60) ;; default to three days - (* 60 1) ;; default to one minute - ;; (* 60 60 25) ;; default to 25 hours - )))) - (print "Keep-running got server pid " server-id ", using iface " iface " and port " port) - (let loop ((count 0)) - (thread-sleep! 4) ;; no need to do this very often - ;; NB// sync currently does NOT return queue-length - (let () ;; (queue-len (cdb:client-call server-info 'sync #t 1))) - ;; (print "Server running, count is " count) - (if (< count 1) ;; 3x3 = 9 secs aprox - (loop (+ count 1))) - - (mutex-lock! *heartbeat-mutex*) - (set! last-access *last-db-access*) - (mutex-unlock! *heartbeat-mutex*) - (db:sync-touched *inmemdb* run-id force-sync: #t) - (if (and *server-run* - (> (+ last-access server-timeout) - (current-seconds))) - (begin - (debug:print-info 0 *default-log-port* "Server continuing, seconds since last db access: " (- (current-seconds) last-access)) - (loop 0)) - (begin - (debug:print-info 0 *default-log-port* "Starting to shutdown the server.") - (set! *time-to-exit* #t) - (db:sync-touched *inmemdb* run-id force-sync: #t) - (tasks:server-delete-record (db:delay-if-busy tdbdat) server-id " http-transport:keep-running") - (debug:print-info 0 *default-log-port* "Server shutdown complete. Exiting") - (exit) - )))))) - -;;====================================================================== -;; C L I E N T S -;;====================================================================== - -(define (nmsg-transport:client-connect iface portnum) - (let* ((reqsoc (nmsg-transport:ping iface portnum return-socket: #t))) - (vector iface portnum #f #f #f (current-seconds) reqsoc))) - -;; returns result, there is no sucess/fail flag - handled via excpections -;; -(define (nmsg-transport:client-api-send-receive run-id connection-info cmd param #!key (remtries 5)) - ;; NB// In the html version of this routine there is a call to - ;; tasks:kill-server-run-id when there is an exception - (mutex-lock! *http-mutex*) - (let* ((packet (vector cmd param)) - (reqsoc (http-transport:server-dat-get-socket connection-info)) - (res (nmsg-transport:client-api-send-receive-raw reqsoc packet))) -;; (status (vector-ref rawres 0)) -;; (result (vector-ref rawres 1))) - (mutex-unlock! *http-mutex*) - res)) ;; (vector status (if status (db:string->obj result transport: 'nmsg) result)))) - -;;====================================================================== -;; J U N K -;;====================================================================== - -;; DO NOT USE -;; -(define (nmsg-transport:client-signal-handler signum) - (handle-exceptions - exn - (debug:print 0 *default-log-port* " ... exiting ...") - (let ((th1 (make-thread (lambda () - (if (not *received-response*) - (receive-message* *runremote*))) ;; 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! 3) ;; give the flush three seconds 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)))) - Index: diff-report.scm ================================================================== --- diff-report.scm +++ diff-report.scm @@ -1,5 +1,20 @@ +;; 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)) Index: docs/Makefile ================================================================== --- docs/Makefile +++ docs/Makefile @@ -1,5 +1,21 @@ +# 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 +29,7 @@ fossil add html/* megatest.pdf : megatest.lyx lyx -e pdf2 megatest.lyx +pkts.pdf : pkts.dot + dot -Tpdf pkts.dot -o pkts.pdf Index: docs/api.html ================================================================== --- docs/api.html +++ docs/api.html @@ -1015,10 +1015,10 @@
Index: docs/api.txt ================================================================== --- docs/api.txt +++ docs/api.txt @@ -15,10 +15,27 @@ ---------------- The Megatest Web App aims to make as much of the power of the dashboard available to the web based user. :numbered: + +// 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. Index: docs/manual/Makefile ================================================================== --- docs/manual/Makefile +++ docs/manual/Makefile @@ -1,10 +1,12 @@ 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 @@ -13,15 +15,15 @@ # 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 -megatest_manual.html : megatest_manual.txt getting_started.txt writing_tests.txt reference.txt ../plan.txt howto.txt installation.txt *png +megatest_manual.html : megatest_manual.txt $(INPAGES) writing_tests.txt installation.txt *png asciidoc -b html5 -a icons -a iconsdir=$(DISPATH)/images/icons -a toc2 megatest_manual.txt # dos2unix megatest_manual.html -megatest.pdf : megatest_manual.txt getting_started.txt writing_tests.txt reference.txt ../plan.txt howto.txt *png +megatest.pdf : megatest_manual.txt $(INPAGES) writing_tests.txt *png a2x -a toc -f pdf megatest_manual.txt server.ps : server.dot dot -Tps server.dot > server.ps @@ -30,7 +32,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 Index: docs/manual/complex-itemmap.dot ================================================================== --- docs/manual/complex-itemmap.dot +++ docs/manual/complex-itemmap.dot @@ -38,10 +38,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/getting_started.in Index: docs/manual/getting_started.in ================================================================== --- /dev/null +++ docs/manual/getting_started.in @@ -0,0 +1,99 @@ + +Getting Started +--------------- + +[partintro] +.Getting started with Megatest +-- +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 +---------------- DELETED docs/manual/getting_started.txt Index: docs/manual/getting_started.txt ================================================================== --- docs/manual/getting_started.txt +++ /dev/null @@ -1,99 +0,0 @@ - -Getting Started ---------------- - -[partintro] -.Getting started with Megatest --- -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 ----------------- ADDED docs/manual/howto.in Index: docs/manual/howto.in ================================================================== --- /dev/null +++ docs/manual/howto.in @@ -0,0 +1,191 @@ +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. + +.Remove the test diskperf and all it's items +---------------- +megatest -remove-runs -target ubuntu/nfs/none -runname ww28.1a -testpatt diskperf/% -v +---------------- + +.Remove all tests for all runs and all targets +---------------- +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/% +---------------- + +Hint: You can browse the archive using bup commands directly. + +---------------- +bup -d /path/to/bup/archive ftp +---------------- + +Submit jobs to Host Types based on Test Name +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +.In megatest.config +------------------------ +[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 +------------------------ + +Tricks +------ + +This section is a compendium of a various useful tricks for debugging, +configuring and generally getting the most out of Megatest. + +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: + +---------------- +[test_meta] +jobgroup group1 +---------------- + +In your megatest.config: + +--------------- +[jobgroups] +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. + +---------------------------- +[misc] +parent #{shell dirname $(readlink -f .)} + +[tests-paths] +1 #{get misc parent}/simplerun/tests +---------------------------- + +The above example shows how you can use addition sections in your +config file to do complex processing. By putting results of relatively +slow operations into variables the processing of your configs can be +kept fast. + +Alternative Method for Running your Job Script +^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + +.Directly running job in testconfig +------------------- +[setup] +runscript main.csh +------------------- + +The runscript method is essentially a brute force way to run scripts where the +user is responsible for setting STATE and STATUS and managing the details of running a test. + +Debugging Server Problems +~~~~~~~~~~~~~~~~~~~~~~~~~ + +Some handy Unix commands to track down issues with servers not +communicating with your test manager processes. Please put in tickets +at https://www.kiatoa.com/fossils/megatest if you have problems with +servers getting stuck. + +---------------- +sudo lsof -i +sudo netstat -lptu +sudo netstat -tulpn +---------------- DELETED docs/manual/howto.txt Index: docs/manual/howto.txt ================================================================== --- docs/manual/howto.txt +++ /dev/null @@ -1,192 +0,0 @@ - -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. - -.Remove the test diskperf and all it's items ----------------- -megatest -remove-runs -target ubuntu/nfs/none -runname ww28.1a -testpatt diskperf/% -v ----------------- - -.Remove all tests for all runs and all targets ----------------- -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/% ----------------- - -Hint: You can browse the archive using bup commands directly. - ----------------- -bup -d /path/to/bup/archive ftp ----------------- - -Submit jobs to Host Types based on Test Name -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -.In megatest.config ------------------------- -[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 ------------------------- - -Tricks ------- - -This section is a compendium of a various useful tricks for debugging, -configuring and generally getting the most out of Megatest. - -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: - ----------------- -[test_meta] -jobgroup group1 ----------------- - -In your megatest.config: - ---------------- -[jobgroups] -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. - ----------------------------- -[misc] -parent #{shell dirname $(readlink -f .)} - -[tests-paths] -1 #{get misc parent}/simplerun/tests ----------------------------- - -The above example shows how you can use addition sections in your -config file to do complex processing. By putting results of relatively -slow operations into variables the processing of your configs can be -kept fast. - -Alternative Method for Running your Job Script -^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ - -.Directly running job in testconfig -------------------- -[setup] -runscript main.csh -------------------- - -The runscript method is essentially a brute force way to run scripts where the -user is responsible for setting STATE and STATUS and managing the details of running a test. - -Debugging Server Problems -~~~~~~~~~~~~~~~~~~~~~~~~~ - -Some handy Unix commands to track down issues with servers not -communicating with your test manager processes. Please put in tickets -at https://www.kiatoa.com/fossils/megatest if you have problems with -servers getting stuck. - ----------------- -sudo lsof -i -sudo netstat -lptu -sudo netstat -tulpn ----------------- Index: docs/manual/megatest_manual.html ================================================================== --- docs/manual/megatest_manual.html +++ docs/manual/megatest_manual.html @@ -801,18 +801,17 @@

Megatest Design Philosophy

-

Megatest is intended to provide the minimum needed resources to make -writing a suite of tests and tasks for 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 or task. In most cases megatest is best used in -conjunction with logpro or a similar tool to parse, analyze and decide -on the test outcome.

+

Megatest is a distributed system intended to provide the minimum needed +resources to make writing a suite of tests and tasks for 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 or task. In most cases megatest is best used in conjunction with +logpro or a similar tool to parse, analyze and decide on the test outcome.

  • Self-checking -Repeatable strive for directed or self-checking test as opposed to delta based tests @@ -868,32 +867,186 @@

Road Map

Note 1: This road-map is still evolving and subject to change without notice.

+
+

RFC M01: Add ability to move runs to other Areas

+

Purpose: allow shrinking megatest.db data by moving runs to an alternate + Megatest area with same keys.

+

Method: extend db sync to take a different megatest area as a destination.

+

Design:

+
    +
  1. +

    +add param -destination [area|path]. when specified runs are copied to new + area and removed from local db. +

    +
    2. +
  2. +

    +the data move would involve these steps +

    +
      +
    1. +

      +copy the run data to destination area megatest.db +

      +
      2. +
    2. +

      +mark the run records as deleted, do not remove the run data on disk +

      +
      3. +
    +
    3. +
  3. +

    +accessing the data would be by running dashboard in the satellite area +

    +
    4. +
  4. +

    +future versions of Megatest dashboard should support displaying areas in a + merged way. +

    +
    5. +
  5. +

    +some new controls would be supported in the config +

    +
      +
    1. +

      +[setup] ⇒ allow-runs [no|yes] ⇐= used to disallow runs +

      +
      2. +
    2. +

      +[setup] ⇒ auto-migrate=[areaname|path] ⇐= used to automatically + migrate data to a satellite area. +

      +
      3. +
    +
    6. +
+

Branch: This work is taking place on branch v1.65-reduce-records

+
+
+

RFC M02: Move data into completed-runs.db

+

Purpose: shrink megatest.db data to enable lower load and higher performance.

+

Method: add a completed-runs.db and automatically move runs data from megatest.db to that db

+

Design:

+
    +
  1. +

    +completed-runs.db is a full megatest database with complete schema +

    +
    2. +
  2. +

    +the data move would involve these steps +

    +
      +
    1. +

      +copy the run data to completed-runs.db +

      +
      2. +
    2. +

      +remove the run data, first from /tmp/…/megatest.db and /tmp/…/megatest_ref.db, followed by megatest.db +

      +
      3. +
    +
    3. +
  3. +

    +accessing the data would be unchanged for most operations. +

    +
    4. +
  4. +

    +a mode -full-db will be added which when specified would attach the completed-runs.db to megatest.db before doing the query +

    +
    5. +
  5. +

    +mechanisms for moving runs to/from the megatest.db would be added +

    +
      +
    1. +

      +-reduce-records ⇒ move runs to completed-runs.db +

      +
      2. +
    2. +

      +-restore-records ⇒ move runs from completed-runs.db to megatest.db +

      +
      3. +
    +
    6. +
+

Branch: This work is taking place on branch v1.65-reduce-records

+
+
+

RFC M03: Automatic homehost migrations

+

Purpose: Automatically migrate homehost.

+

Method: Check that there are no tests running, launched or remotehoststart in past ½ hour then if not on homehost migrate the db to current host

+

Design:

+
    +
  1. +

    +Check that the system is quiescent, i.e. that there are no runs in flight or recently run +

    +
    2. +
  2. +

    +Create a lock +

    +
    3. +
  3. +

    +Migrate the /tmp cache db to the current host +

    +
    4. +
  4. +

    +Update the .homehost file +

    +
    5. +
  5. +

    +Remove the lock +

    +
    6. +
+

Branch: This work not yet started

+

Architecture Refactor

Goals

  1. Reduce load on the file system. Sqlite3 files on network filesystem can be - a burden. + a burden. [DONE]

  2. Reduce number of servers and frequency of start/stop. This is mostly an - issue of clutter but also a reduction in "moving parts". + issue of clutter but also a reduction in "moving parts". [DONE]

  3. Coalesce activities to a single home host where possible. Give the user feedback that they have started the dashboard on a host other than the - home host. + home host. [DONE]

  4. Reduce number of processes involved in managing running tests. @@ -905,35 +1058,35 @@

    Changes Needed

    1. ACID compliant db will be on /tmp and synced to megatest.db with a five - second max delay. + second max delay. [DONE]

    2. Read/writes to db for processes on homehost will go direct to /tmp - megatest.db file. + megatest.db file. [DONE]

    3. Read/wites fron non-homehost processes will go through one server. Bulk reads (e.g. for dashboard or list-runs) will be cached on the current host - in /tmp and synced from the home megatest.db in the testsuite area. + in /tmp and synced from the home megatest.db in the testsuite area. [DONE]

    4. -Db syncs rely on the target db file timestame minus some margin. +Db syncs rely on the target db file timestame minus some margin. [DONE]

    5. Since bulk reads do not use the server we can switch to simple RPC for the - network transport. + network transport. [DONE]

    6. Test running manager process extended to manage multiple running tests. @@ -947,31 +1100,32 @@

      ww05 - migrate to inmem-db

      1. -Switch to inmem db with fast sync to on disk db’s [DONE] +Switch to inmem db with fast sync to on disk db’s [DONE]

      2. Server polls tasks table for next action

        1. -Task table used for tracking runner process [DONE] +Task table used for tracking runner process [Replaced by mtutil]

        2. -Task table used for jobs to run +Task table used for jobs to run [Replaced by mtutil]

        3. -Task table used for queueing runner actions (remove runs, cleanRunExecute, etc) +Task table used for queueing runner actions (remove runs, + cleanRunExecute, etc) [Replaced by mtutil]

      @@ -1415,15 +1569,35 @@ 
      [items]
 A a b c
 B d e f

    Then the config file would effectively appear to contain an items section -exactly like the output from the script. This is extremely useful when -dynamically creating items, itemstables and other config structures. You can -see the expansion of the call by looking in the cached files (look in your -linktree for megatest.config and runconfigs.config cache files and in your -test run areas for the expanded and cached testconfig).

    +exactly like the output from the script. This is useful when dynamically +creating items, itemstables and other config structures. You can see the +expansion of the call by looking in the cached files (look in your linktree +for megatest.config and runconfigs.config cache files and in your test run +areas for the expanded and cached testconfig).

+

Wildcards and regexes in Targets

+
+
+
[a/2/b]
+VAR1 VAL1
+
+[a/%/b]
+VAR1 VAL2
+
+

Will result in:

+
+
+
[a/2/b]
+VAR1 VAL2
+
+

Can use either wildcard of "%" or a regular expression:

+
+
+
[/abc.*def/]
+

Disk Space Checks

Some parameters you can put in the [setup] section of megatest.config:

@@ -1490,10 +1664,19 @@
In megatest.config
[setup]
 reruns 5
+

Replace the default blacklisted environment variables with user supplied +list.

+

Default list: USER HOME DISPLAY LS_COLORS XKEYSYMDB EDITOR MAKEFLAGS MAKEF MAKEOVERRIDES

+
Add a "bad" variable "PROMPT" to the variables that will be commented out

in the megatest.sh and megatest.csh files:

+
+
+
[setup]
+blacklistvars USER HOME DISPLAY LS_COLORS XKEYSYMDB EDITOR MAKEFLAGS PROMPT
+
Run time limit
@@ -1524,10 +1707,43 @@ 
[setup]
 nodot
+
+
+

Capturing Test Data

+

In a test you can capture arbitrary variables and roll them up in the +megatest database for viewing on the dashboard or web app.

+
+
In a test as a script
+
+
$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
+
+

Alternatively you can use logpro triggers to capture values and inject them +into megatest using the -set-values mechanism:

+
+
Megatest help related to -set-values
+
+
Test data capture
+  -set-values             : update or set values in the testdata table
+  :category               : set the category field (optional)
+  :variable               : set the variable name (optional)
+  :value                  : value measured (required)
+  :expected               : value expected (required)
+  :tol                    : |value-expect| <= tol (required, can be <, >, >=, <= or number)
+  :units                  : name of the units for value, expected_value etc. (optional)
+

Dashboard settings

Runs tab buttons, font and size
@@ -1563,16 +1779,10 @@

Prevent concurrent access issues

yes|no or not defined

Default=no, may help on some network file systems, may slow things down also.

-

daemonize

-

Daemonize the server on start

-

yes|no or not defined

-

Default=no

- -

faststart

All direct file access to sqlite db files

yes|no or not defined

Default=yes, suggest no for central automated systems and yes for interactive use

@@ -1697,92 +1907,148 @@

Itemmap Handling

For cases were the dependent test has a similar but not identical itempath to the downstream test an itemmap can allow for itemmatch mode

+
example for removing part of itemmap for waiton test (eg: item foo-x/bar depends on waiton’s item y/bar)
[requirements]
-mode itemmatch
-itemmap .*x/ y/
-
-# ## pattern replacement notes
+mode itemwait
+# itemmap <item pattern for this test>  <item replacement pattern for waiton test>
+itemmap .*x/ y/
+
+
+
example for removing part of itemmap for waiton test (eg: item foo/bar/baz in this test depends on waiton’s item baz)
+
+
# ## pattern replacement notes
 #
 # ## Example
 # ## Remove everything up to the last /
-itemmap .*/
-#
+[requirements]
+mode itemwait
+# itemmap <item pattern for this test> <nothing here indicates removal>
+itemmap .*/
+
+
+
example replacing part of itemmap for (eg: item foo/1234 will imply waiton’s item bar/1234)
+
+
#
 # ## Example
 # ## Replace foo/ with bar/
-itemmap foo/ bar/
-
-# multi-line; matches are applied in the listed order
+[requirements]
+mode itemwait
+# itemmap <item pattern for this test>  <item replacement pattern for waiton test>
+itemmap foo/ bar/
+
+
+
example for backreference (eg: item foo23/thud will imply waiton’s item num-23/bar/thud
+
+
#
+# ## Example
+# ## can use \{number} in replacement pattern to backreference a (capture) from matching pattern similar to sed or perl
+[requirements]
+mode itemwait
+# itemmap <item pattern for this test>  <item replacement pattern for waiton test>
+itemmap foo(\d+)/ num-\1/bar/
+
+
+
example multiple itemmaps
+
+
# multi-line; matches are applied in the listed order
 # The following would map:
 #   a123b321 to b321fooa123 then to 321fooa123p
 #
+[requirements]
 itemmap (a\d+)(b\d+) \2foo\1
   b(.*) \1p
-

Complex mappings

-

Complex mappings can be handled with the [itemmap] section

+

Complex mapping

+

Complex mappings can be handled with a separate [itemmap] section (instead if an itemmap line in the [requirements] section)

+

Each line in an itemmap section starts with a waiton test name followed by an itemmap expression

+
+
eg: The following causes waiton test A item bar/1234 to run when our test’s foo/1234 item is requested as well as causing waiton test B’s blah item to run when our test’s stuff/blah item is requested
+
+
[itemmap]
+A foo/ bar/
+B stuff/
+
+
+
+

Complex mapping example

complex-itemmap.png
-

Example:

-
    -
  1. -

    -Request to run D/1/res -

    -
    2. -
  2. -

    -Megatest uses rule "(\d+)/res" → "\1/aa" to create item C/1/aa from D/1/res -

    -
    3. -
  3. -

    -Full list to be run is now: D/1/res, C/1/aa -

    -
    4. -
  4. -

    -Megatest uses rule "(\d+)/aa" → "aa/\1" to create item A/aa/1 -

    -
    5. -
  5. -

    -Full list to be run is now: D/1/res, C/1/aa, A/aa/1 -

    -
    6. -
+

We accomplish this by configuring the testconfigs of our tests C D and E as follows:

-
Testconfig for Test C
+
Testconfig for Test E has
[requirements]
-waiton A B
-
-[itemmap]
-A (\d+)/aa aa/\1
-B (\d+)/bb
+waiton C +itemmap (\d+)/res \1/bb
-
Testconfig for Test D
+
Testconfig for Test D has
[requirements]
 waiton C
 itemmap (\d+)/res \1/aa
-
Testconfig for Test E
+
Testconfig for Test C has
[requirements]
-waiton C
-itemmap (\d+)/res \1/bb
+waiton A B + +[itemmap] +A (\d+)/aa aa/\1 +B (\d+)/bb bb/\1 +
+
+
Testconfigs for Test B and Test A have no waiton or itemmap configured
+
+

 

+
Walk through one item — we want the following to happen for testpatt D/1/res (see blue boxes in complex itemmaping figure above):
    
+
  1. 
+
    
+eg from command line megatest -run -testpatt D/1/res -target mytarget -runname myrunname
+
    
+
    2. 
+
  2. 
+
    
+Full list to be run is now: D/1/res
+
    
+
    3. 
+
  3. 
+
    
+Test D has a waiton - test C.  Test D’s itemmap rule itemmap (\d+)/res \1/aa →  causes C/1/aa to run before D/1/res
+
    
+
    4. 
+
  4. 
+
    
+Full list to be run is now: D/1/res, C/1/aa
+
    
+
    5. 
+
  5. 
+
    
+Test C was a waiton - test A. Test C’s rule A (\d+)/aa aa/\1 → causes A/aa/1 to run before C/1/aa
+
    
+
    6. 
+
  6. 
+
    
+Full list to be run is now: D/1/res, C/1/aa, A/aa/1
+
    
+
    7. 
+
  7. 
+
    
+Test A has no waitons.  All waitons of all tests in full list have been processed.  Full list is finalized.
+
    
+
    8. 
+

 

 

 
Dynamic Flow Dependency Tree

 

 
Autogeneration waiton list for dynamic flow dependency trees

@@ -1893,11 +2159,11 @@
 
$MT_MEGATEST -env2file .ezsteps/${stepname}

 

 

 

 
Triggers

-
In your testconfig triggers can be specified

+
In your testconfig or megatest.config triggers can be specified

 

 

 
[triggers]
 
 # Call script running.sh when test goes to state=RUNNING, status=PASS
@@ -1907,11 +2173,11 @@
 RUNNING/ running.sh
 
 # Call script onpass.sh any time status goes to PASS
 PASS/ onpass.sh

 

-
Scripts called will have; test-id test-rundir trigger, added to the commandline.

+
Scripts called will have; test-id test-rundir trigger test-name item-path state status event-time, added to the commandline.

 
HINT

 
To start an xterm (useful for debugging), use a command line like the following:

 

 

 
[triggers]
@@ -1923,10 +2189,78 @@
 Note
 
 There is a trailing space after the --
 
 

+
There are a number of environment variables available to the trigger script
+but since triggers can be called in various contexts not all variables are
+available at all times. The trigger script should check for the variable and
+fail gracefully if it doesn’t exist.

+
+
+++
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
Table 4. Environment variables visible to the trigger script


Variable              Purpose
MT_TEST_RUN_DIR
The directory where Megatest ran this test
MT_CMDINFO
Encoded command data for the test
MT_DEBUG_MODE
Used to pass the debug mode to nested calls to Megatest
MT_RUN_AREA_HOME
Megatest home area
MT_TESTSUITENAME
The name of this testsuite or area
MT_TEST_NAME
The name of this test
MT_ITEM_INFO
The variable and values for the test item
MT_MEGATEST
Which Megatest binary is being used by this area
MT_TARGET
The target variable values, separated by /
MT_LINKTREE
The base of the link tree where all run tests can be found
MT_ITEMPATH
The values of the item path variables, separated by /
MT_RUNNAME
The name of the run

 

 

 
Override the Toplevel HTML File

 
Megatest generates a simple html file summary for top level tests of
 iterated tests. The generation can be overridden. NOTE: the output of
@@ -1996,26 +2330,111 @@
 
Then in runconfigs.config

 

 
Example of using modified.config in a testconfig

 

 
cat testconfig
-
 [pre-launch-env-vars]
 [include modified.config]

 

 

 

+

+

+
Managing Old Runs

+

+
It is often desired to keep some older runs around but this must be balanced with the costs of disk space.

+
    
+
  1. 
+
    
+Use -remove-keep
+
    
+
    2. 
+
  2. 
+
    
+Use -archive (can also be done from the -remove-keep interface)
+
    
+
    3. 
+
  3. 
+
    
+use -remove-runs with -keep-records
+
    
+
    4. 
+

+

+
For each target, remove all runs but the most recent 3 if they are over 1 week old

+

+
# use -precmd 'sleep 5;nbfake' to limit overloading the host computer but to allow the removes to run in parallel.
+megatest -actions print,remove-runs -remove-keep 3 -target %/%/%/% -runname % -age 1w -precmd 'sleep 5;nbfake'"

+

+

+

+

+
Nested Runs

+

+
A Megatest test can run a full Megatest run in either the same
+Megatest area or in another area. This is a powerful way of chaining
+complex suites of tests and or actions.

+
If you are not using the current area you can use ezsteps to retrieve
+and setup the sub-Megatest run area.

+
In the testconfig:

+

+

+
[subrun]
+
+# Required: wait for the run or just launch it
+#           if no then the run will be an automatic PASS irrespective of the actual result
+run-wait yes|no
+
+# Optional: where to execute the run. Default is the current runarea
+run-area /some/path/to/megatest/area
+
+# Optional: method to use to determine pass/fail status of the run
+#   auto (default) - roll up the net state/status of the sub-run
+#   logpro         - use the provided logpro rules, happens automatically if there is a logpro section
+# passfail auto|logpro
+# Example of logpro:
+passfail logpro
+
+# Optional:
+logpro ;; if this section exists then logpro is used to determine pass/fail
+  (expect:required in "LogFileBody" >= 1 "At least one pass" #/PASS/)
+  (expect:fail     in "LogFileBody"  = 0 "No FAILs allowed"  #/FAIL/)
+
+# Optional: target translator, default is to use the parent target
+target #{shell somescript.sh}
+
+# Optional: runname translator/generator, default is to use the parent runname
+run-name #{somescript.sh}
+
+# Optional: testpatt spec, default is to first look for TESTPATT spec from runconfigs unless there is a contour spec
+test-patt %/item1,test2
+
+# Optional: contour spec, use the named contour from the megatest.config contour spec
+contour contourname ### NOTE: Not implemented yet! Let us know if you need this feature.
+
+# Optional: mode-patt, use this spec for testpatt from runconfigs
+mode-patt TESTPATT
+
+# Optional: tag-expr, use this tag-expr to select tests
+tag-expr quick
+
+# Optional: (not yet implemented, remove-runs is always propagated at this time), propagate these actions from the parent
+#           test
+#   Note// default is % for all
+propagate remove-runs archive ...

+

+

 

 

 
Programming API

 

 
These routines can be called from the megatest repl.

 
-
+
@@ -2063,10 +2482,10 @@
 


Index: docs/manual/megatest_manual.txt
==================================================================
--- docs/manual/megatest_manual.txt
+++ docs/manual/megatest_manual.txt
@@ -24,18 +24,17 @@
 qualification.
 
 Megatest Design Philosophy
 --------------------------
 
-Megatest is intended to provide the minimum needed resources to make
-writing a suite of tests and tasks for 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 or task. In most cases megatest is best used in
-conjunction with logpro or a similar tool to parse, analyze and decide
-on the test outcome. 
+Megatest is a distributed system intended to provide the minimum needed
+resources to make writing a suite of tests and tasks for 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 or task. In most cases megatest is best used in conjunction with
+logpro or a similar tool to parse, analyze and decide on the test outcome.
 
  * Self-checking -Repeatable strive for directed or self-checking test
    as opposed to delta based tests
 
  * Traceable - environment variables, host OS and other possibly influential
@@ -62,24 +61,24 @@
 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.
 
-include::../plan.txt[]
+include::plan.in[]
 // to allow the getting_started.txt to be a stand-alone document use level
 shifting, note that the preceding blank line is needed.
 // :leveloffset: 2
 
 include::installation.txt[]
 
-include::getting_started.txt[]
+include::getting_started.in[]
 
 :leveloffset: 0
 
 include::writing_tests.txt[]
-include::howto.txt[]
-include::reference.txt[]
+include::howto.in[]
+include::reference.in[]
 
 Megatest Internals
 ------------------
 
 ["graphviz", "server.png"]

ADDED   docs/manual/plan.in
Index: docs/manual/plan.in
==================================================================
--- /dev/null
+++ docs/manual/plan.in
@@ -0,0 +1,189 @@
+Road Map
+--------
+
+Note 1: This road-map is still evolving and subject to change without notice.
+
+RFC M01: Add ability to move runs to other Areas
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+*Purpose*: allow shrinking megatest.db data by moving runs to an alternate
+ Megatest area with same keys.
+
+*Method*: extend db sync to take a different megatest area as a destination.
+
+*Design*:
+
+. add param -destination [area|path]. when specified runs are copied to new
+  area and removed from local db.
+. the data move would involve these steps
+.. copy the run data to destination area megatest.db
+.. mark the run records as deleted, do not remove the run data on disk
+. accessing the data would be by running dashboard in the satellite area
+. future versions of Megatest dashboard should support displaying areas in a
+  merged way.
+. some new controls would be supported in the config
+.. [setup] => allow-runs [no|yes]  <== used to disallow runs
+.. [setup] => auto-migrate=[areaname|path]  <== used to automatically
+   migrate data to a satellite area.
+
+*Branch*: This work is taking place on branch v1.65-reduce-records
+
+RFC M02: Move data into completed-runs.db
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+*Purpose*: shrink megatest.db data to enable lower load and higher performance.
+
+*Method*: add a completed-runs.db and automatically move runs data from megatest.db to that db
+
+*Design*:
+
+. completed-runs.db is a full megatest database with complete schema
+. the data move would involve these steps
+.. copy the run data to completed-runs.db
+.. remove the run data, first from /tmp/…/megatest.db and /tmp/…/megatest_ref.db, followed by megatest.db
+. accessing the data would be unchanged for most operations.
+. a mode -full-db will be added which when specified would attach the completed-runs.db to megatest.db before doing the query
+. mechanisms for moving runs to/from the megatest.db would be added
+.. -reduce-records => move runs to completed-runs.db
+.. -restore-records => move runs from completed-runs.db to megatest.db
+
+*Branch*: This work is taking place on branch v1.65-reduce-records
+
+RFC M03: Automatic homehost migrations
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+*Purpose*: Automatically migrate homehost.
+
+*Method*: Check that there are no tests running, launched or remotehoststart in past ½ hour then if not on homehost migrate the db to current host
+
+*Design*:
+
+. Check that the system is quiescent, i.e. that there are no runs in flight or recently run
+. Create a lock
+. Migrate the /tmp cache db to the current host
+. Update the .homehost file
+. Remove the lock
+
+*Branch*: This work not yet started
+
+Architecture Refactor
+~~~~~~~~~~~~~~~~~~~~~
+
+Goals
+^^^^^
+
+. Reduce load on the file system. Sqlite3 files on network filesystem can be
+  a burden. [green]#[DONE]#
+. Reduce number of servers and frequency of start/stop. This is mostly an
+  issue of clutter but also a reduction in "moving parts". [green]#[DONE]#
+. Coalesce activities to a single home host where possible. Give the user
+  feedback that they have started the dashboard on a host other than the
+  home host. [green]#[DONE]#
+. Reduce number of processes involved in managing running tests.
+
+Changes Needed
+^^^^^^^^^^^^^^
+
+. ACID compliant db will be on /tmp and synced to megatest.db with a five
+  second max delay. [green]#[DONE]#
+. Read/writes to db for processes on homehost will go direct to /tmp
+  megatest.db file. [green]#[DONE]#
+. Read/wites fron non-homehost processes will go through one server. Bulk
+  reads (e.g. for dashboard or list-runs) will be cached on the current host
+  in /tmp and synced from the home megatest.db in the testsuite area. [green]#[DONE]#
+. Db syncs rely on the target db file timestame minus some margin. [green]#[DONE]#
+. Since bulk reads do not use the server we can switch to simple RPC for the
+  network transport. [green]#[DONE]#
+. Test running manager process extended to manage multiple running tests.
+
+Current Items
+~~~~~~~~~~~~~
+
+ww05 - migrate to inmem-db
+^^^^^^^^^^^^^^^^^^^^^^^^^^
+
+. Switch to inmem db with fast sync to on disk db's [green]#[DONE]#
+. Server polls tasks table for next action
+.. Task table used for tracking runner process [red]#[Replaced by mtutil]#
+.. Task table used for jobs to run [red]#[Replaced by mtutil]#
+.. Task table used for queueing runner actions (remove runs,
+   cleanRunExecute, etc)  [red]#[Replaced by mtutil#]
+
+
+// ww32
+// ~~~~
+// 
+// . Rerun step and or subsequent steps from gui
+// . Refresh test area files from gui
+// . Clean and re-run button
+// . Clean up STATE and STATUS handling.
+// .. Dashboard and Test control panel are reverse order - choose and fix
+// .. Move seldom used states and status to drop down selector
+// . Access test control panel when clicking on Run Summary tests
+// . Feature: -generate-index-tree
+// . Change specifing of state and status to use STATE1/STATUS1,STATE2/STATUS2
+// 
+// ww33
+// ~~~~
+// 
+// . http api available for use with Perl, Ruby etc. scripts
+// . megatest.config setup entries for:
+// .. run launching (e.g. /bin/sh %CMD% > /dev/null)
+// .. browser "konqueror %FNAME%
+// 
+// ww34
+// ~~~~
+// 
+// . Mark dependent tests for clean/rerun -rerun-downstream
+// . On run start check for defunct tests in RUNNING, LAUNCHED or REMOTEHOSTSTART and correct or notify
+// . Fix: refresh of gui sometimes fails on last item (race condition?)
+// 
+// ww35
+// ~~~~
+// 
+// . refdb: Add export of csv, json and sexp
+// . Convert to using call-with-environment-variables where possible. Should allow handling of parallel runs in same process.
+// . Re-work text interface wizards. Several bugs on record. Possibly convert to gui based.
+// . Add to testconfig requirements section; launchlimiter scriptname, calls scriptname to check if ok to launch test
+// . Refactor Run Summary view, currently very clumsy
+// . Add option to show steps in Run Summary view
+// 
+// ww36
+// ~~~~
+// 
+// . Refactor guis for resizeablity
+// . Add filters to Run Summary view and Run Control view
+// . Add to megatest.config or testconfig; rerunok STATE/STATUS,STATE/STATUS...
+// . Launch gates for diskspace; /path/one>1G,/path/two>200M,/tmp>5G,#{scheme *toppath*}>1G
+// 
+// Bin List
+// ~~~~~~~~
+// 
+// .	Quality improvements
+// ..	Server stutters occasionally
+// ..	Large number of items or tests still has some issues.
+// ..	Code refactoring
+// ..	Replace remote process with true API using json (supports Web app also)
+// .	Streamline the gui
+// ..	Everything resizable
+// ..	Less clutter
+// ..	Tool tips
+// ..	Filters on Run Summary, Summary and Run Control panel
+// ..	Built in log viewer (partially implemented)
+// ..	Refactor the test control panel
+// .	Help and documentation
+// ..	Complete the user manual (I’ve been working on this lately).
+// ..	Online help in the gui
+// .	Streamlined install
+// ..	Deployed version (download a location independent ready to run binary bundle)
+// ..	Install Makefile (in progress, needed for Mike to install on VMs)
+// ..	Added option to compile IUP (needed for VMs)
+// .	Server side run launching
+// .	Support for re-running, cleaning etc. of individual steps (ezsteps makes this very easy to implement).
+// .	Launch process needs built in daemonizing (easy to do, just need to test it thoroughly).
+// .	Wizards for creating tests, regression areas (current ones are text only and limited).
+// .	Fully functional built in web service (currently you can browse runs but it is very simplistic).
+// .	Wildcards in runconfigs: e.g. [p1271/9/%/%]
+// .	Gui panels for editing megatest.config and runconfigs.config
+// .	Fully isolated tests (no use of NFS to see regression area files)
+// .	Windows version

ADDED   docs/manual/reference.in
Index: docs/manual/reference.in
==================================================================
--- /dev/null
+++ docs/manual/reference.in
@@ -0,0 +1,798 @@
+Reference
+---------
+
+Config File Helpers
+~~~~~~~~~~~~~~~~~~~
+
+Various helpers for more advanced config files.
+
+.Helpers
+[width="80%",cols="^,2m,2m,2m",frame="topbot",options="header"]
+|======================
+|Helper                      | Purpose                       | Valid values            | Comments
+| #{scheme (scheme code...)} | Execute arbitrary scheme code | Any valid scheme        | Value returned from the call is converted to a string and processed as part of the config file
+| #{system command}          | Execute program, inserts exit code  | Any valid Unix command  | Discards the output from the program
+| #{shell  command} or #{sh ...}  | Execute program, inserts result from stdout | Any valid Unix command | Value returned from the call is converted to a string and processed as part of the config file
+| #{realpath path} or #{rp ...}   | Replace with normalized path | Must be a valid path |
+| #{getenv VAR} or #{gv VAR}      | Replace with content of env variable | Must be a valid var |
+| #{get s v} or #{g s v}     | Replace with variable v from section s | Variable must be defined before use |
+| #{rget v}                  | Replace with variable v from target or default of runconfigs file | |
+| #{mtrah}                   | Replace with the path to the megatest testsuite area | | 
+|======================
+
+Config File Settings
+~~~~~~~~~~~~~~~~~~~~
+
+Settings in megatest.config
+
+Config File Additional Features
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+Including output from a script as if it was inline to the config file:
+
+-------------------------
+[scriptinc myscript.sh]
+-------------------------
+
+If the script outputs:
+
+-------------------------
+[items]
+A a b c
+B d e f
+-------------------------
+
+Then the config file would effectively appear to contain an items section
+exactly like the output from the script. This is useful when dynamically
+creating items, itemstables and other config structures. You can see the
+expansion of the call by looking in the cached files (look in your linktree
+for megatest.config and runconfigs.config cache files and in your test run
+areas for the expanded and cached testconfig).
+
+Wildcards and regexes in Targets
+
+-------------------------
+[a/2/b]
+VAR1 VAL1
+
+[a/%/b]
+VAR1 VAL2
+-------------------------
+
+Will result in:
+
+-------------------------
+[a/2/b]
+VAR1 VAL2
+-------------------------
+
+Can use either wildcard of "%" or a regular expression:
+
+-------------------------
+[/abc.*def/]
+-------------------------
+
+Disk Space Checks
+^^^^^^^^^^^^^^^^^
+
+Some parameters you can put in the [setup] section of megatest.config:
+
+-------------------
+# minimum space required in a run disk 
+minspace 10000000
+
+# minimum space required in dbdir:
+dbdir-space-required 100000
+
+# script that takes path as parameter and returns number of bytes available:
+free-space-script check-space.sh
+-------------------
+
+Trim trailing spaces
+^^^^^^^^^^^^^^^^^^^^
+
+------------------
+[configf:settings trim-trailing-spaces yes]
+------------------
+
+Job Submission Control
+^^^^^^^^^^^^^^^^^^^^^^
+
+Submit jobs to Host Types based on Test Name
+++++++++++++++++++++++++++++++++++++++++++++
+
+.In megatest.config
+------------------------
+[host-types]
+general   nbfake
+remote    bsub
+
+[launchers]
+runfirst/sum% remote
+% general
+
+[jobtools]
+launcher bsub
+# if defined and not "no" flexi-launcher will bypass launcher unless 
+# there is no host-type match.
+flexi-launcher yes
+------------------------
+
+host-types
+++++++++++
+
+List of host types and the commandline to run a job on that host type.
+
+.host-type => launch command
+------------
+general nbfake
+------------
+
+launchers
++++++++++
+
+.test/itempath => host-type
+------------
+runfirst/sum% remote
+------------
+
+Miscellaneous Setup Items
++++++++++++++++++++++++++
+
+Attempt to rerun tests in "STUCK/DEAD", "n/a", "ZERO_ITEMS" states.
+
+.In megatest.config
+------------------
+[setup]
+reruns 5
+------------------
+
+Replace the default blacklisted environment variables with user supplied
+list.
+
+Default list: USER HOME DISPLAY LS_COLORS XKEYSYMDB EDITOR MAKEFLAGS MAKEF MAKEOVERRIDES
+
+.Add a "bad" variable "PROMPT" to the variables that will be commented out
+in the megatest.sh and megatest.csh files:
+-----------------
+[setup]
+blacklistvars USER HOME DISPLAY LS_COLORS XKEYSYMDB EDITOR MAKEFLAGS PROMPT
+-----------------
+
+Run time limit
+++++++++++++++
+
+-----------------
+[setup]
+# this will automatically kill the test if it runs for more than 1h 2m and 3s
+runtimelim 1h 2m 3s
+-----------------
+
+Tests browser view
+~~~~~~~~~~~~~~~~~~
+
+The tests browser (see the Run Control tab on the dashboard) has two views for displaying the tests. 
+
+. Dot (graphviz) based tree
+. No dot, plain listing
+
+The default is the graphviz based tree but if your tests don't view
+well in that mode then use "nodot" to turn it off.
+
+-----------------
+[setup]
+nodot
+-----------------
+
+Capturing Test Data
+~~~~~~~~~~~~~~~~~~~
+
+In a test you can capture arbitrary variables and roll them up in the
+megatest database for viewing on the dashboard or web app.
+
+.In a test as a script
+------------------------
+$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
+------------------------
+
+Alternatively you can use logpro triggers to capture values and inject them
+into megatest using the -set-values mechanism:
+
+.Megatest help related to -set-values
+------------------------
+Test data capture
+  -set-values             : update or set values in the testdata table
+  :category               : set the category field (optional)
+  :variable               : set the variable name (optional)
+  :value                  : value measured (required)
+  :expected               : value expected (required)
+  :tol                    : |value-expect| <= tol (required, can be <, >, >=, <= or number)
+  :units                  : name of the units for value, expected_value etc. (optional)
+------------------------
+
+Dashboard settings
+~~~~~~~~~~~~~~~~~~
+
+.Runs tab buttons, font and size
+------------------
+[dashboard]
+btn-height x14
+btn-fontsz 10
+cell-width 60
+------------------
+
+Database settings
+~~~~~~~~~~~~~~~~~
+
+.Database config settings in [setup] section of megatest.config
+[width="70%",cols="^,2m,2m,2m",frame="topbot",options="header"]
+|======================
+|Var                       | Purpose            | Valid values            | Comments
+|delay-on-busy             | Prevent concurrent access issues | yes\|no or not defined | Default=no, may help on some network file systems, may slow things down also.
+|faststart		   | All direct file access to sqlite db files | yes\|no or not defined | Default=yes, suggest no for central automated systems and yes for interactive use
+|homehost 		   | Start servers on this host |  | Defaults to local host
+|hostname		   | Hostname to bind to | \|-	  | On multi-homed hosts allows binding to specific hostname
+|lowport		   | Start searching for a port at this portnum| 32768 | 
+|required		   | Server required    | yes\|no or not defined  | Default=no, force start of server always
+|server-query-threshold	   | Start server when queries take longer than this | number in milliseconds | Default=300
+|timeout		   | http api timeout 	| number in hours	  | Default is 1 minute, do not change
+|======================
+
+The testconfig File
+-------------------
+
+Setup section
+~~~~~~~~~~~~~
+
+Header
+^^^^^^
+
+-------------------
+[setup]
+-------------------
+
+The runscript method is a brute force way to run scripts where the
+user is responsible for setting STATE and STATUS
+
+-------------------
+runscript main.csh
+-------------------
+
+Requirements section
+~~~~~~~~~~~~~~~~~~~~
+
+.Header
+-------------------
+[requirements]
+-------------------
+
+Wait on Other Tests
+^^^^^^^^^^^^^^^^^^^
+
+-------------------
+# A normal waiton waits for the prior tests to be COMPLETED 
+# and PASS, CHECK or WAIVED
+waiton test1 test2
+-------------------
+
+Mode
+^^^^
+
+The default (i.e. if mode is not specified) is normal. All pre-dependent tests
+must be COMPLETED and PASS, CHECK or WAIVED before the test will start
+
+-------------------
+[requirements]
+mode   normal
+-------------------
+
+The toplevel mode requires only that the prior tests are COMPLETED.
+
+-------------------
+[requirements]
+mode toplevel
+-------------------
+
+A item based waiton will start items in a test when the same-named
+item is COMPLETED and PASS, CHECK or WAIVED in the prior test. This
+was historically called "itemwait" mode. The terms "itemwait" and
+"itemmatch" are synonyms.
+
+-------------------
+[requirements]
+mode itemmatch
+-------------------
+
+Overriding Enviroment Variables
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+Override variables before starting the test. Can include files (perhaps generated by megatest -envdelta or similar).
+
+--------------------
+[pre-launch-env-vars]
+VAR1 value1
+
+# Get some generated settings
+[include ../generated-vars.config]
+
+# Use this trick to unset variables
+#{scheme (unsetenv "FOOBAR")}
+--------------------
+
+Itemmap Handling
+~~~~~~~~~~~~~~~~
+
+For cases were the dependent test has a similar but not identical
+itempath to the downstream test an itemmap can allow for itemmatch
+mode
+
+.example for removing part of itemmap for waiton test (eg: item +foo-x/bar+ depends on waiton's item +y/bar+)
+-------------------
+[requirements]
+mode itemwait
+# itemmap   
+itemmap .*x/ y/
+
+-------------------
+
+.example for removing part of itemmap for waiton test (eg: item +foo/bar/baz+ in this test depends on waiton's item +baz+)
+-------------------
+
+# ## pattern replacement notes
+#
+# ## Example
+# ## Remove everything up to the last /
+[requirements]
+mode itemwait
+# itemmap  
+itemmap .*/
+-------------------
+
+.example replacing part of itemmap for (eg: item +foo/1234+ will imply waiton's item +bar/1234+)
+-------------------
+
+#
+# ## Example
+# ## Replace foo/ with bar/
+[requirements]
+mode itemwait
+# itemmap   
+itemmap foo/ bar/
+
+-------------------
+
+.example for backreference (eg: item +foo23/thud+ will imply waiton's item +num-23/bar/thud+
+-------------------
+#
+# ## Example
+# ## can use \{number} in replacement pattern to backreference a (capture) from matching pattern similar to sed or perl
+[requirements]
+mode itemwait
+# itemmap   
+itemmap foo(\d+)/ num-\1/bar/
+
+-------------------
+
+.example multiple itemmaps
+-------------------
+
+# multi-line; matches are applied in the listed order
+# The following would map:
+#   a123b321 to b321fooa123 then to 321fooa123p
+#
+[requirements]
+itemmap (a\d+)(b\d+) \2foo\1
+  b(.*) \1p
+-------------------
+
+
+Complex mapping
+^^^^^^^^^^^^^^^
+Complex mappings can be handled with a separate [itemmap] section (instead if an itemmap line in the [requirements] section)
+
+Each line in an itemmap section starts with a waiton test name followed by an itemmap expression
+
+.eg: The following causes waiton test A item +bar/1234+ to run when our test's +foo/1234+ item is requested as well as causing waiton test B's +blah+ item to run when our test's +stuff/blah+ item is requested
+--------------
+[itemmap]
+A foo/ bar/
+B stuff/
+--------------
+
+
+Complex mapping example
+^^^^^^^^^^^^^^^^^^^^^^^
+
+
+
+// image::itemmap.png[]
+image::complex-itemmap.png[]
+
+
+We accomplish this by configuring the testconfigs of our tests C D and E as follows:
+
+.Testconfig for Test E has
+----------------------
+[requirements]
+waiton C
+itemmap (\d+)/res \1/bb
+----------------------
+
+.Testconfig for Test D has
+----------------------
+[requirements]
+waiton C
+itemmap (\d+)/res \1/aa
+----------------------
+
+.Testconfig for Test C has
+----------------------
+[requirements]
+waiton A B
+
+[itemmap]
+A (\d+)/aa aa/\1
+B (\d+)/bb bb/\1
+----------------------
+
+.Testconfigs for Test B and Test A have no waiton or itemmap configured
+-------------------
+-------------------
+
+.Walk through one item -- we want the following to happen for testpatt +D/1/res+ (see blue boxes in complex itemmaping figure above):
+
+. eg from command line +megatest -run -testpatt D/1/res -target mytarget -runname myrunname+
+. Full list to be run is now: +D/1/res+
+. Test D has a waiton - test C.  Test D's itemmap rule +itemmap (\d+)/res \1/aa+ ->  causes +C/1/aa+ to run before +D/1/res+
+. Full list to be run is now: +D/1/res+, +C/1/aa+
+. Test C was a waiton - test A. Test C's rule +A (\d+)/aa aa/\1+ -> causes +A/aa/1+ to run before +C/1/aa+
+. Full list to be run is now: +D/1/res+, +C/1/aa+, +A/aa/1+
+. Test A has no waitons.  All waitons of all tests in full list have been processed.  Full list is finalized.
+
+
+Dynamic Flow Dependency Tree
+^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+
+.Autogeneration waiton list for dynamic flow dependency trees
+-------------------
+[requirements]
+# With a toplevel test you may wish to generate your list 
+# of tests to run dynamically
+#
+waiton #{shell get-valid-tests-to-run.sh}
+-------------------
+
+Run time limit
+^^^^^^^^^^^^^^
+
+-----------------
+[requirements]
+runtimelim 1h 2m 3s  # this will automatically kill the test if it runs for more than 1h 2m and 3s
+-----------------
+
+Skip
+^^^^
+
+A test with a skip section will conditional skip running.
+
+.Skip section example
+-----------------
+[skip]
+prevrunning x
+# rundelay 30m 15s
+-----------------
+
+Skip on Still-running Tests
+^^^^^^^^^^^^^^^^^^^^^^^^^^^
+
+-----------------
+# NB// If the prevrunning line exists with *any* value the test will
+# automatically SKIP if the same-named test is currently RUNNING. The
+# "x" can be any string. Comment out the prevrunning line to turn off
+# skip.
+
+[skip]
+prevrunning x
+-----------------
+
+Skip if a File Exists
+^^^^^^^^^^^^^^^^^^^^^
+
+-----------------
+[skip]
+fileexists /path/to/a/file # skip if /path/to/a/file exists
+-----------------
+
+Skip if test ran more recently than specified time
+^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+
+.Skip if this test has been run in the past fifteen minutes and 15 seconds.
+-----------------
+[skip]
+rundelay 15m 15s
+-----------------
+
+Disks
+^^^^^
+
+A disks section in testconfig will override the disks section in
+megatest.config. This can be used to allocate disks on a per-test or per item
+basis.
+
+Controlled waiver propagation
+^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+
+If test is FAIL and previous test in run with same MT_TARGET is WAIVED then apply the following rules from the testconfig:
+If a waiver check is specified in the testconfig apply the check and if it passes then set this FAIL to WAIVED
+
+Waiver check has two parts, 1) a list of waiver, rulename, filepatterns and 2) the rulename script spec (note that "diff" and "logpro" are predefined)
+
+-----------------
+###### EXAMPLE FROM testconfig #########
+# 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]
+# logpro_file    rulename      input_glob
+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
+-----------------
+
+Ezsteps
+~~~~~~~
+
+.Example ezsteps with logpro rules
+-----------------
+[ezsteps]
+lookittmp   ls /tmp
+
+[logpro]
+lookittmp ;; Note: config file format supports multi-line entries where leading whitespace is removed from each line
+  ;;     a blank line indicates the end of the block of text 
+  (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/)
+
+-----------------
+
+To transfer the environment to the next step you can do the following:
+
+----------------------------
+$MT_MEGATEST -env2file .ezsteps/${stepname}	  
+----------------------------
+
+Triggers
+~~~~~~~~
+
+In your testconfig or megatest.config triggers can be specified 
+
+-----------------
+[triggers]
+
+# Call script running.sh when test goes to state=RUNNING, status=PASS
+RUNNING/PASS running.sh
+
+# Call script running.sh any time state goes to RUNNING
+RUNNING/ running.sh
+
+# Call script onpass.sh any time status goes to PASS
+PASS/ onpass.sh
+-----------------
+
+Scripts called will have; test-id test-rundir trigger test-name item-path state status event-time, added to the commandline.
+
+HINT
+
+To start an xterm (useful for debugging), use a command line like the following:
+
+-----------------
+[triggers]
+COMPLETED/ xterm -e bash -s -- 
+-----------------
+
+NOTE: There is a trailing space after the --
+
+There are a number of environment variables available to the trigger script
+but since triggers can be called in various contexts not all variables are
+available at all times. The trigger script should check for the variable and
+fail gracefully if it doesn't exist.
+
+.Environment variables visible to the trigger script
+[width="90%",cols="^,2m",frame="topbot",options="header"]
+|======================
+|Variable             | Purpose            
+| MT_TEST_RUN_DIR     | The directory where Megatest ran this test                   
+| MT_CMDINFO          | Encoded command data for the test                   
+| MT_DEBUG_MODE       | Used to pass the debug mode to nested calls to Megatest                   
+| MT_RUN_AREA_HOME    | Megatest home area 
+| MT_TESTSUITENAME    | The name of this testsuite or area                   
+| MT_TEST_NAME        | The name of this test
+| MT_ITEM_INFO        | The variable and values for the test item
+| MT_MEGATEST         | Which Megatest binary is being used by this area
+| MT_TARGET           | The target variable values, separated by '/'
+| MT_LINKTREE         | The base of the link tree where all run tests can be found
+| MT_ITEMPATH         | The values of the item path variables, separated by '/'
+| MT_RUNNAME          | The name of the run
+|======================
+
+
+Override the Toplevel HTML File
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+Megatest generates a simple html file summary for top level tests of
+iterated tests. The generation can be overridden. NOTE: the output of
+the script is captured from stdout to create the html.
+
+
+.For test "runfirst" override the toplevel generation with a script "mysummary.sh"
+-----------------
+# Override the rollup for specific tests
+[testrollup]
+runfirst mysummary.sh
+-----------------
+
+Archiving Setup
+---------------
+
+In megatest.config add the following sections:
+
+.megatest.config
+--------------
+[archive]
+# where to get bup executable
+# bup /path/to/bup
+
+[archive-disks]
+
+# Archives will be organised under these paths like this:
+#  /
+# Within the archive the data is structured like this:
+#  ///
+archive0 /mfs/myarchive-data/adisk1
+--------------
+
+Handling Environment Variables
+------------------------------
+
+It is often necessary to capture and or manipulate environment
+variables. Megatest has some facilities built in to help.
+
+Capture variables
+~~~~~~~~~~~~~~~~~
+
+.Commands
+------------------------------
+# capture the current enviroment into a db called envdat.db under
+# the context "before"
+megatest -envcap before
+
+# capture the current environment into a db called startup.db with 
+# context "after"
+megatest -envcap after startup.db
+
+# write the diff from before to after
+megatest -envdelta before-after -dumpmode bash
+------------------------------
+
+Dump modes include bash, csh and config. You can include config data
+into megatest.config or runconfigs.config.
+
+.Example of generating and using config data
+------------------------------
+megatest -envcap original
+# do some stuff here
+megatest -envcap munged
+megatest -envdelta original-munged -dumpmode ini -o modified.config
+------------------------------
+
+Then in runconfigs.config
+
+.Example of using modified.config in a testconfig
+------------------------------
+cat testconfig
+[pre-launch-env-vars]
+[include modified.config]
+------------------------------
+
+Managing Old Runs
+-----------------
+
+It is often desired to keep some older runs around but this must be balanced with the costs of disk space.
+
+. Use -remove-keep
+. Use -archive (can also be done from the -remove-keep interface)
+. use -remove-runs with -keep-records
+
+.For each target, remove all runs but the most recent 3 if they are over 1 week old
+---------------------
+# use -precmd 'sleep 5;nbfake' to limit overloading the host computer but to allow the removes to run in parallel.
+megatest -actions print,remove-runs -remove-keep 3 -target %/%/%/% -runname % -age 1w -precmd 'sleep 5;nbfake'"
+---------------------
+
+Nested Runs
+-----------
+
+A Megatest test can run a full Megatest run in either the same
+Megatest area or in another area. This is a powerful way of chaining
+complex suites of tests and or actions.
+
+If you are not using the current area you can use ezsteps to retrieve
+and setup the sub-Megatest run area.
+
+In the testconfig:
+---------------
+[subrun]
+
+# Required: wait for the run or just launch it
+#           if no then the run will be an automatic PASS irrespective of the actual result
+run-wait yes|no
+
+# Optional: where to execute the run. Default is the current runarea
+run-area /some/path/to/megatest/area
+
+# Optional: method to use to determine pass/fail status of the run
+#   auto (default) - roll up the net state/status of the sub-run
+#   logpro         - use the provided logpro rules, happens automatically if there is a logpro section
+# passfail auto|logpro
+# Example of logpro:
+passfail logpro
+
+# Optional: 
+logpro ;; if this section exists then logpro is used to determine pass/fail
+  (expect:required in "LogFileBody" >= 1 "At least one pass" #/PASS/)
+  (expect:fail     in "LogFileBody"  = 0 "No FAILs allowed"  #/FAIL/)
+
+# Optional: target translator, default is to use the parent target
+target #{shell somescript.sh}
+
+# Optional: runname translator/generator, default is to use the parent runname
+run-name #{somescript.sh}
+
+# Optional: testpatt spec, default is to first look for TESTPATT spec from runconfigs unless there is a contour spec
+test-patt %/item1,test2
+
+# Optional: contour spec, use the named contour from the megatest.config contour spec
+contour contourname ### NOTE: Not implemented yet! Let us know if you need this feature.
+
+# Optional: mode-patt, use this spec for testpatt from runconfigs
+mode-patt TESTPATT
+
+# Optional: tag-expr, use this tag-expr to select tests
+tag-expr quick
+
+# Optional: (not yet implemented, remove-runs is always propagated at this time), propagate these actions from the parent
+#           test
+#   Note// default is % for all
+propagate remove-runs archive ...
+
+---------------
+
+Programming API
+---------------
+
+These routines can be called from the megatest repl. 
+
+.API Keys Related Calls
+[width="70%",cols="^,2m,2m,2m",frame="topbot",options="header,footer"]
+|======================
+|API Call                        | Purpose comments   | Returns                 | Comments
+|(rmt:get-keys run-id)           |                    | ( key1 key2 ... )       | 
+| (rmt:get-key-val-pairs run-id) |                    | #t=success/#f=fail      | Works only if the server is still reachable
+|======================
+
+
+:numbered!:

DELETED docs/manual/reference.txt
Index: docs/manual/reference.txt
==================================================================
--- docs/manual/reference.txt
+++ /dev/null
@@ -1,597 +0,0 @@
-
-Reference
----------
-
-Config File Helpers
-~~~~~~~~~~~~~~~~~~~
-
-Various helpers for more advanced config files.
-
-.Helpers
-[width="80%",cols="^,2m,2m,2m",frame="topbot",options="header"]
-|======================
-|Helper                      | Purpose                       | Valid values            | Comments
-| #{scheme (scheme code...)} | Execute arbitrary scheme code | Any valid scheme        | Value returned from the call is converted to a string and processed as part of the config file
-| #{system command}          | Execute program, inserts exit code  | Any valid Unix command  | Discards the output from the program
-| #{shell  command} or #{sh ...}  | Execute program, inserts result from stdout | Any valid Unix command | Value returned from the call is converted to a string and processed as part of the config file
-| #{realpath path} or #{rp ...}   | Replace with normalized path | Must be a valid path |
-| #{getenv VAR} or #{gv VAR}      | Replace with content of env variable | Must be a valid var |
-| #{get s v} or #{g s v}     | Replace with variable v from section s | Variable must be defined before use |
-| #{rget v}                  | Replace with variable v from target or default of runconfigs file | |
-| #{mtrah}                   | Replace with the path to the megatest testsuite area | | 
-|======================
-
-Config File Settings
-~~~~~~~~~~~~~~~~~~~~
-
-Settings in megatest.config
-
-Config File Additional Features
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-Including output from a script as if it was inline to the config file:
-
--------------------------
-[scriptinc myscript.sh]
--------------------------
-
-If the script outputs:
-
--------------------------
-[items]
-A a b c
-B d e f
--------------------------
-
-Then the config file would effectively appear to contain an items section
-exactly like the output from the script. This is useful when dynamically
-creating items, itemstables and other config structures. You can see the
-expansion of the call by looking in the cached files (look in your linktree
-for megatest.config and runconfigs.config cache files and in your test run
-areas for the expanded and cached testconfig).
-
-Wildcards and regexes in Targets
-
--------------------------
-[a/2/b]
-VAR1 VAL1
-
-[a/%/b]
-VAR1 VAL2
--------------------------
-
-Will result in:
-
--------------------------
-[a/2/b]
-VAR1 VAL2
--------------------------
-
-Can use either wildcard of "%" or a regular expression:
-
-[/abc.*def/]
-
-Disk Space Checks
-^^^^^^^^^^^^^^^^^
-
-Some parameters you can put in the [setup] section of megatest.config:
-
--------------------
-# minimum space required in a run disk 
-minspace 10000000
-
-# minimum space required in dbdir:
-dbdir-space-required 100000
-
-# script that takes path as parameter and returns number of bytes available:
-free-space-script check-space.sh
--------------------
-
-Trim trailing spaces
-^^^^^^^^^^^^^^^^^^^^
-
-------------------
-[configf:settings trim-trailing-spaces yes]
-------------------
-
-Job Submission Control
-^^^^^^^^^^^^^^^^^^^^^^
-
-Submit jobs to Host Types based on Test Name
-++++++++++++++++++++++++++++++++++++++++++++
-
-.In megatest.config
-------------------------
-[host-types]
-general   nbfake
-remote    bsub
-
-[launchers]
-runfirst/sum% remote
-% general
-
-[jobtools]
-launcher bsub
-# if defined and not "no" flexi-launcher will bypass launcher unless 
-# there is no host-type match.
-flexi-launcher yes
-------------------------
-
-host-types
-++++++++++
-
-List of host types and the commandline to run a job on that host type.
-
-.host-type => launch command
-------------
-general nbfake
-------------
-
-launchers
-+++++++++
-
-.test/itempath => host-type
-------------
-runfirst/sum% remote
-------------
-
-Miscellaneous Setup Items
-+++++++++++++++++++++++++
-
-Attempt to rerun tests in "STUCK/DEAD", "n/a", "ZERO_ITEMS" states.
-
-.In megatest.config
-------------------
-[setup]
-reruns 5
-------------------
-
-Run time limit
-++++++++++++++
-
------------------
-[setup]
-# this will automatically kill the test if it runs for more than 1h 2m and 3s
-runtimelim 1h 2m 3s
------------------
-
-Tests browser view
-~~~~~~~~~~~~~~~~~~
-
-The tests browser (see the Run Control tab on the dashboard) has two views for displaying the tests. 
-
-. Dot (graphviz) based tree
-. No dot, plain listing
-
-The default is the graphviz based tree but if your tests don't view
-well in that mode then use "nodot" to turn it off.
-
------------------
-[setup]
-nodot
------------------
-
-Dashboard settings
-~~~~~~~~~~~~~~~~~~
-
-.Runs tab buttons, font and size
-------------------
-[dashboard]
-btn-height x14
-btn-fontsz 10
-cell-width 60
-------------------
-
-Database settings
-~~~~~~~~~~~~~~~~~
-
-.Database config settings in [setup] section of megatest.config
-[width="70%",cols="^,2m,2m,2m",frame="topbot",options="header"]
-|======================
-|Var                       | Purpose            | Valid values            | Comments
-|delay-on-busy             | Prevent concurrent access issues | yes\|no or not defined | Default=no, may help on some network file systems, may slow things down also.
-|daemonize                 | Daemonize the server on start | yes\|no or not defined | Default=no
-|faststart		   | All direct file access to sqlite db files | yes\|no or not defined | Default=yes, suggest no for central automated systems and yes for interactive use
-|homehost 		   | Start servers on this host |  | Defaults to local host
-|hostname		   | Hostname to bind to | \|-	  | On multi-homed hosts allows binding to specific hostname
-|lowport		   | Start searching for a port at this portnum| 32768 | 
-|required		   | Server required    | yes\|no or not defined  | Default=no, force start of server always
-|server-query-threshold	   | Start server when queries take longer than this | number in milliseconds | Default=300
-|timeout		   | http api timeout 	| number in hours	  | Default is 1 minute, do not change
-|======================
-
-The testconfig File
--------------------
-
-Setup section
-~~~~~~~~~~~~~
-
-Header
-^^^^^^
-
--------------------
-[setup]
--------------------
-
-The runscript method is a brute force way to run scripts where the
-user is responsible for setting STATE and STATUS
-
--------------------
-runscript main.csh
--------------------
-
-Requirements section
-~~~~~~~~~~~~~~~~~~~~
-
-.Header
--------------------
-[requirements]
--------------------
-
-Wait on Other Tests
-^^^^^^^^^^^^^^^^^^^
-
--------------------
-# A normal waiton waits for the prior tests to be COMPLETED 
-# and PASS, CHECK or WAIVED
-waiton test1 test2
--------------------
-
-Mode
-^^^^
-
-The default (i.e. if mode is not specified) is normal. All pre-dependent tests
-must be COMPLETED and PASS, CHECK or WAIVED before the test will start
-
--------------------
-[requirements]
-mode   normal
--------------------
-
-The toplevel mode requires only that the prior tests are COMPLETED.
-
--------------------
-[requirements]
-mode toplevel
--------------------
-
-A item based waiton will start items in a test when the same-named
-item is COMPLETED and PASS, CHECK or WAIVED in the prior test. This
-was historically called "itemwait" mode. The terms "itemwait" and
-"itemmatch" are synonyms.
-
--------------------
-[requirements]
-mode itemmatch
--------------------
-
-Overriding Enviroment Variables
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-Override variables before starting the test. Can include files (perhaps generated by megatest -envdelta or similar).
-
---------------------
-[pre-launch-env-vars]
-VAR1 value1
-
-# Get some generated settings
-[include ../generated-vars.config]
-
-# Use this trick to unset variables
-#{scheme (unsetenv "FOOBAR")}
---------------------
-
-Itemmap Handling
-~~~~~~~~~~~~~~~~
-
-For cases were the dependent test has a similar but not identical
-itempath to the downstream test an itemmap can allow for itemmatch
-mode
-
--------------------
-[requirements]
-mode itemmatch
-itemmap .*x/ y/
-
-# ## pattern replacement notes
-#
-# ## Example
-# ## Remove everything up to the last /
-itemmap .*/
-#
-# ## Example
-# ## Replace foo/ with bar/
-itemmap foo/ bar/
-
-# multi-line; matches are applied in the listed order
-# The following would map:
-#   a123b321 to b321fooa123 then to 321fooa123p
-#
-itemmap (a\d+)(b\d+) \2foo\1
-  b(.*) \1p
--------------------
-
-Complex mappings
-^^^^^^^^^^^^^^^^
-
-Complex mappings can be handled with the [itemmap] section
-
-// image::itemmap.png[]
-image::complex-itemmap.png[]
-
-Example:
-
-. Request to run D/1/res
-. Megatest uses rule "(\d+)/res" -> "\1/aa" to create item C/1/aa from D/1/res
-. Full list to be run is now: D/1/res, C/1/aa
-. Megatest uses rule "(\d+)/aa" -> "aa/\1" to create item A/aa/1
-. Full list to be run is now: D/1/res, C/1/aa, A/aa/1
-
-.Testconfig for Test C
-----------------------
-[requirements]
-waiton A B
-
-[itemmap]
-A (\d+)/aa aa/\1
-B (\d+)/bb 
-----------------------
-
-.Testconfig for Test D
-----------------------
-[requirements]
-waiton C
-itemmap (\d+)/res \1/aa
-----------------------
-
-.Testconfig for Test E
-----------------------
-[requirements]
-waiton C
-itemmap (\d+)/res \1/bb
-----------------------
-
-Dynamic Flow Dependency Tree
-^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-
-.Autogeneration waiton list for dynamic flow dependency trees
--------------------
-[requirements]
-# With a toplevel test you may wish to generate your list 
-# of tests to run dynamically
-#
-waiton #{shell get-valid-tests-to-run.sh}
--------------------
-
-Run time limit
-^^^^^^^^^^^^^^
-
------------------
-[requirements]
-runtimelim 1h 2m 3s  # this will automatically kill the test if it runs for more than 1h 2m and 3s
------------------
-
-Skip
-^^^^
-
-A test with a skip section will conditional skip running.
-
-.Skip section example
------------------
-[skip]
-prevrunning x
-# rundelay 30m 15s
------------------
-
-Skip on Still-running Tests
-^^^^^^^^^^^^^^^^^^^^^^^^^^^
-
------------------
-# NB// If the prevrunning line exists with *any* value the test will
-# automatically SKIP if the same-named test is currently RUNNING. The
-# "x" can be any string. Comment out the prevrunning line to turn off
-# skip.
-
-[skip]
-prevrunning x
------------------
-
-Skip if a File Exists
-^^^^^^^^^^^^^^^^^^^^^
-
------------------
-[skip]
-fileexists /path/to/a/file # skip if /path/to/a/file exists
------------------
-
-Skip if test ran more recently than specified time
-^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-
-.Skip if this test has been run in the past fifteen minutes and 15 seconds.
------------------
-[skip]
-rundelay 15m 15s
------------------
-
-Disks
-^^^^^
-
-A disks section in testconfig will override the disks section in
-megatest.config. This can be used to allocate disks on a per-test or per item
-basis.
-
-Controlled waiver propagation
-^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-
-If test is FAIL and previous test in run with same MT_TARGET is WAIVED then apply the following rules from the testconfig:
-If a waiver check is specified in the testconfig apply the check and if it passes then set this FAIL to WAIVED
-
-Waiver check has two parts, 1) a list of waiver, rulename, filepatterns and 2) the rulename script spec (note that "diff" and "logpro" are predefined)
-
------------------
-###### EXAMPLE FROM testconfig #########
-# 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]
-# logpro_file    rulename      input_glob
-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
------------------
-
-Ezsteps
-~~~~~~~
-
-.Example ezsteps with logpro rules
------------------
-[ezsteps]
-lookittmp   ls /tmp
-
-[logpro]
-lookittmp ;; Note: config file format supports multi-line entries where leading whitespace is removed from each line
-  ;;     a blank line indicates the end of the block of text 
-  (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/)
-
------------------
-
-To transfer the environment to the next step you can do the following:
-
-----------------------------
-$MT_MEGATEST -env2file .ezsteps/${stepname}	  
-----------------------------
-
-Triggers
-~~~~~~~~
-
-In your testconfig triggers can be specified 
-
------------------
-[triggers]
-
-# Call script running.sh when test goes to state=RUNNING, status=PASS
-RUNNING/PASS running.sh
-
-# Call script running.sh any time state goes to RUNNING
-RUNNING/ running.sh
-
-# Call script onpass.sh any time status goes to PASS
-PASS/ onpass.sh
------------------
-
-Scripts called will have; test-id test-rundir trigger, added to the commandline.
-
-HINT
-
-To start an xterm (useful for debugging), use a command line like the following:
-
------------------
-[triggers]
-COMPLETED/ xterm -e bash -s -- 
------------------
-
-NOTE: There is a trailing space after the --
-
-
-Override the Toplevel HTML File
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-Megatest generates a simple html file summary for top level tests of
-iterated tests. The generation can be overridden. NOTE: the output of
-the script is captured from stdout to create the html.
-
-
-.For test "runfirst" override the toplevel generation with a script "mysummary.sh"
------------------
-# Override the rollup for specific tests
-[testrollup]
-runfirst mysummary.sh
------------------
-
-Archiving Setup
----------------
-
-In megatest.config add the following sections:
-
-.megatest.config
---------------
-[archive]
-# where to get bup executable
-# bup /path/to/bup
-
-[archive-disks]
-
-# Archives will be organised under these paths like this:
-#  /
-# Within the archive the data is structured like this:
-#  ///
-archive0 /mfs/myarchive-data/adisk1
---------------
-
-Handling Environment Variables
-------------------------------
-
-It is often necessary to capture and or manipulate environment
-variables. Megatest has some facilities built in to help.
-
-Capture variables
-~~~~~~~~~~~~~~~~~
-
-.Commands
-------------------------------
-# capture the current enviroment into a db called envdat.db under
-# the context "before"
-megatest -envcap before
-
-# capture the current environment into a db called startup.db with 
-# context "after"
-megatest -envcap after startup.db
-
-# write the diff from before to after
-megatest -envdelta before-after -dumpmode bash
-------------------------------
-
-Dump modes include bash, csh and config. You can include config data
-into megatest.config or runconfigs.config.
-
-.Example of generating and using config data
-------------------------------
-megatest -envcap original
-# do some stuff here
-megatest -envcap munged
-megatest -envdelta original-munged -dumpmode ini -o modified.config
-------------------------------
-
-Then in runconfigs.config
-
-.Example of using modified.config in a testconfig
-------------------------------
-cat testconfig
-
-[pre-launch-env-vars]
-[include modified.config]
-------------------------------
-
-
-Programming API
----------------
-
-These routines can be called from the megatest repl. 
-
-.API Keys Related Calls
-[width="70%",cols="^,2m,2m,2m",frame="topbot",options="header,footer"]
-|======================
-|API Call                        | Purpose comments   | Returns                 | Comments
-|(rmt:get-keys run-id)           |                    | ( key1 key2 ... )       | 
-| (rmt:get-key-val-pairs run-id) |                    | #t=success/#f=fail      | Works only if the server is still reachable
-|======================
-
-
-:numbered!:
-

ADDED   docs/megatest-desktop.png
Index: docs/megatest-desktop.png
==================================================================
--- /dev/null
+++ docs/megatest-desktop.png
cannot compute difference between binary files

Index: docs/megatest-state-status.dot
==================================================================
--- docs/megatest-state-status.dot
+++ docs/megatest-state-status.dot
@@ -1,5 +1,21 @@
+// 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 megatest_state_status {
   ranksep=0.05
   // rankdir=LR
 
 node [shape=box,style=filled];
@@ -31,11 +47,11 @@
      label="{RUNNING|{n/a| PASS | FAIL}}";
   ]
 
   "COMPLETED" [
       shape="record";
-      label = "{COMPLETED|{PASS |  FAIL | CHECK| SKIP}}";
+      label = "{COMPLETED|{PASS | SKIP | WAIVED | FAIL | CHECK| ABORT}}";
   ]
 
 
 "RUNNING" -> "COMPLETED";
 "RUNNING" -> "INCOMPLETE" [label="test dead for > 24hrs"];

ADDED   docs/pkts.dot
Index: docs/pkts.dot
==================================================================
--- /dev/null
+++ docs/pkts.dot
@@ -0,0 +1,59 @@
+digraph megatest_pkts {
+  ranksep=0.05
+  // rankdir=LR
+
+node [shape=box,style=filled];
+  
+  "SENSORS" [ label = "{ Sensor Processing | { file | git | fossil | script }}"
+	      shape = "record"; ];
+  
+  "RUNS"    [ label = "{ Runs Processing | { launch | clean | re-run | archive } | { dispatcher }}";
+	      shape = "record"; ];
+
+  "WORK"    [ label = "{ Work Items | { start task | task competed }}";
+	      shape = "record"; ];
+
+  "USERREQ" [ label = "{ User Requests (Unix and Web) | { launch | clean | re-run | archive }}";
+	      shape = "record"; ];
+
+  "MTAREA1" [ label = "{ Megatest Area 1 | { parallel job\nmanagement | test\nmanagement | data\nrollup }}";
+	      shape = "record"; ];
+  
+  "MTAREA2" [ label = "{ Megatest Area 2 | { parallel job\nmanagement | test\nmanagement | data\nrollup }}";
+	      shape = "record"; ];
+  
+  "MTAREA3" [ label = "More Megatest Areas ... ";
+	      shape = "record"; ];
+
+  "PGDB"    [ label = "postgres database";
+	      shape = "cylinder"; ];
+
+  "WEBAPP"  [ label = "{ Web View | { Runs | Contours | Control | Time View }}";
+	      shape = "record"; ];
+
+  // "WEBCTRL" [ label = "{ Web View \n(control) }";
+  //	      shape = "record"; ];
+  
+  "SENSORS" -> "SPKTS";
+  "RUNS"    -> "run pkts";
+  "run pkts" -> "RUNS";
+  "WORK"    -> "work pkts";
+  "work pkts" -> "RUNS";
+  "USERREQ" -> "user request pkts";
+  "SPKTS"   -> "RUNS";
+  "user request pkts" -> "RUNS";
+  "RUNS"    -> "MTAREA1" -> "PGDB";
+  "RUNS"    -> "MTAREA2" -> "PGDB";
+  "RUNS"    -> "MTAREA3" -> "PGDB";
+  "PGDB"    -> "WEBAPP";
+  // "WEBCTRL" -> "run pkts";
+  
+  subgraph cluster_pkts {
+    label="Packets";
+    "SPKTS" [ label = "Sensor Packets" ];
+    "run pkts";
+    "work pkts";
+    "user request pkts";
+  }
+}
+

ADDED   docs/pkts.pdf
Index: docs/pkts.pdf
==================================================================
--- /dev/null
+++ docs/pkts.pdf
cannot compute difference between binary files

DELETED docs/plan.txt
Index: docs/plan.txt
==================================================================
--- docs/plan.txt
+++ /dev/null
@@ -1,126 +0,0 @@
-Road Map
---------
-
-Note 1: This road-map is still evolving and subject to change without notice.
-
-Architecture Refactor
-~~~~~~~~~~~~~~~~~~~~~
-
-Goals
-^^^^^
-
-. Reduce load on the file system. Sqlite3 files on network filesystem can be
-  a burden.
-. Reduce number of servers and frequency of start/stop. This is mostly an
-  issue of clutter but also a reduction in "moving parts".
-. Coalesce activities to a single home host where possible. Give the user
-  feedback that they have started the dashboard on a host other than the
-  home host.
-. Reduce number of processes involved in managing running tests.
-
-Changes Needed
-^^^^^^^^^^^^^^
-
-. ACID compliant db will be on /tmp and synced to megatest.db with a five
-  second max delay.
-. Read/writes to db for processes on homehost will go direct to /tmp
-  megatest.db file.
-. Read/wites fron non-homehost processes will go through one server. Bulk
-  reads (e.g. for dashboard or list-runs) will be cached on the current host
-  in /tmp and synced from the home megatest.db in the testsuite area.
-. Db syncs rely on the target db file timestame minus some margin.
-. Since bulk reads do not use the server we can switch to simple RPC for the
-  network transport.
-. Test running manager process extended to manage multiple running tests.
-
-Current Items
-~~~~~~~~~~~~~
-
-ww05 - migrate to inmem-db
-^^^^^^^^^^^^^^^^^^^^^^^^^^
-
-. Switch to inmem db with fast sync to on disk db's [DONE]
-. Server polls tasks table for next action
-.. Task table used for tracking runner process [DONE]
-.. Task table used for jobs to run
-.. Task table used for queueing runner actions (remove runs, cleanRunExecute, etc)
-
-
-// ww32
-// ~~~~
-// 
-// . Rerun step and or subsequent steps from gui
-// . Refresh test area files from gui
-// . Clean and re-run button
-// . Clean up STATE and STATUS handling.
-// .. Dashboard and Test control panel are reverse order - choose and fix
-// .. Move seldom used states and status to drop down selector
-// . Access test control panel when clicking on Run Summary tests
-// . Feature: -generate-index-tree
-// . Change specifing of state and status to use STATE1/STATUS1,STATE2/STATUS2
-// 
-// ww33
-// ~~~~
-// 
-// . http api available for use with Perl, Ruby etc. scripts
-// . megatest.config setup entries for:
-// .. run launching (e.g. /bin/sh %CMD% > /dev/null)
-// .. browser "konqueror %FNAME%
-// 
-// ww34
-// ~~~~
-// 
-// . Mark dependent tests for clean/rerun -rerun-downstream
-// . On run start check for defunct tests in RUNNING, LAUNCHED or REMOTEHOSTSTART and correct or notify
-// . Fix: refresh of gui sometimes fails on last item (race condition?)
-// 
-// ww35
-// ~~~~
-// 
-// . refdb: Add export of csv, json and sexp
-// . Convert to using call-with-environment-variables where possible. Should allow handling of parallel runs in same process.
-// . Re-work text interface wizards. Several bugs on record. Possibly convert to gui based.
-// . Add to testconfig requirements section; launchlimiter scriptname, calls scriptname to check if ok to launch test
-// . Refactor Run Summary view, currently very clumsy
-// . Add option to show steps in Run Summary view
-// 
-// ww36
-// ~~~~
-// 
-// . Refactor guis for resizeablity
-// . Add filters to Run Summary view and Run Control view
-// . Add to megatest.config or testconfig; rerunok STATE/STATUS,STATE/STATUS...
-// . Launch gates for diskspace; /path/one>1G,/path/two>200M,/tmp>5G,#{scheme *toppath*}>1G
-// 
-// Bin List
-// ~~~~~~~~
-// 
-// .	Quality improvements
-// ..	Server stutters occasionally
-// ..	Large number of items or tests still has some issues.
-// ..	Code refactoring
-// ..	Replace remote process with true API using json (supports Web app also)
-// .	Streamline the gui
-// ..	Everything resizable
-// ..	Less clutter
-// ..	Tool tips
-// ..	Filters on Run Summary, Summary and Run Control panel
-// ..	Built in log viewer (partially implemented)
-// ..	Refactor the test control panel
-// .	Help and documentation
-// ..	Complete the user manual (I’ve been working on this lately).
-// ..	Online help in the gui
-// .	Streamlined install
-// ..	Deployed version (download a location independent ready to run binary bundle)
-// ..	Install Makefile (in progress, needed for Mike to install on VMs)
-// ..	Added option to compile IUP (needed for VMs)
-// .	Server side run launching
-// .	Support for re-running, cleaning etc. of individual steps (ezsteps makes this very easy to implement).
-// .	Launch process needs built in daemonizing (easy to do, just need to test it thoroughly).
-// .	Wizards for creating tests, regression areas (current ones are text only and limited).
-// .	Fully functional built in web service (currently you can browse runs but it is very simplistic).
-// .	Wildcards in runconfigs: e.g. [p1271/9/%/%]
-// .	Gui panels for editing megatest.config and runconfigs.config
-// .	Fully isolated tests (no use of NFS to see regression area files)
-// .	Windows version
-

DELETED ducttape/Makefile
Index: ducttape/Makefile
==================================================================
--- ducttape/Makefile
+++ /dev/null
@@ -1,33 +0,0 @@
-help:
-	@echo ""
-	@echo "make targets:"
-	@echo "============="
-	@echo "install      - build and install general_lib egg as icfadm"
-	@echo "test         - run unit tests on ducttape-lib.scm (tests code, not egg)"
-	@echo "eggs-info     - show chicken-install commands to get eggs upon which ducttape-lib depends"
-	@echo "test_example - compile an example scm against installed general_lib egg"
-	@echo "clean        - remove binaries and other build artifacts"
-	@echo ""
-
-clean:
-	rm -f *.so *.import.scm test_ducttape test_example foo *.c *.o
-
-install:
-	chicken-install
-
-test:
-	chicken-install -no-install
-	csc test_ducttape.scm
-
-	./test_ducttape
-	rm -f foo
-
-test_example:
-	@csc test_example.scm
-	@./test_example
-	@rm test_example
-
-eggs-info:
-	@echo chicken-install ansi-escape-sequences
-	@echo chicken-install slice
-	@echo chicken-install rfc3339

DELETED ducttape/README
Index: ducttape/README
==================================================================
--- ducttape/README
+++ /dev/null
@@ -1,8 +0,0 @@
-This directory holds the "ducttape" chicken scheme egg used by megatest.
-
-Run "make test" to ensure this egg works on your system.
-
-Run "make install" as your admin user with chicken on your $PATH to install this egg.
-
-
-

DELETED ducttape/ducttape-lib.meta
Index: ducttape/ducttape-lib.meta
==================================================================
--- ducttape/ducttape-lib.meta
+++ /dev/null
@@ -1,13 +0,0 @@
-;;; ducttape-lib.meta -*- Hen -*-
-
-((egg "ducttape-lib.egg")
- (synopsis "Miscellaneous tool and standard print routines.")
- (category env)
- (author "Brandon Barclay")
- (doc-from-wiki)
- (license "GPL-2")
- ;; srfi-69, posix, srfi-18
- (depends regex)
- (test-depends test)
- ; suspicious - (files "ducttape-lib")
- )

DELETED ducttape/ducttape-lib.scm
Index: ducttape/ducttape-lib.scm
==================================================================
--- ducttape/ducttape-lib.scm
+++ /dev/null
@@ -1,747 +0,0 @@
-(module ducttape-lib
-    (
-     runs-ok
-     ducttape-debug-level
-     ducttape-debug-regex-filter
-     ducttape-silent-mode
-     ducttape-quiet-mode
-     ducttape-log-file
-     ducttape-color-mode
-     iputs-preamble
-     script-name
-     idbg
-     ierr
-     iwarn
-     inote
-     iputs
-     re-match?
-                                        ;     launch-repl
-     keyword-skim
-     skim-cmdline-opts-noarg-by-regex
-     skim-cmdline-opts-withargs-by-regex 
-     concat-lists
-     ducttape-process-command-line
-     ducttape-append-logfile
-     ducttape-activate-logfile
-     isys
-     do-or-die
-     counter-maker
-     dir-is-writable?
-     mktemp
-     get-tmpdir
-     sendmail
-     find-exe
-
-     zeropad
-     string-leftpad
-     string-rightpad
-     seconds->isodate
-     seconds->wwdate
-     seconds->wwdate-values
-     isodate->seconds
-     isodate->wwdate
-     wwdate->seconds
-     wwdate->isodate
-     current-wwdate
-     current-isodate
-     
-     )
-
-  (import scheme chicken extras ports data-structures )
-  (use posix regex ansi-escape-sequences test srfi-1 irregex slice srfi-13 rfc3339)
-  ;;scsh-process ;; dropping scsh-process, it was clobbering posix's process and process*
-  (use directory-utils uuid-lib filepath srfi-19 ) ; linenoise
-  
-  (include "mimetypes.scm") ; provides ext->mimetype
-  (include "workweekdate.scm")
-  (define ducttape-lib-version 1.00)
-  (define (toplevel-command sym proc) (lambda () #f))
-;;;; utility procedures
-
-  ;; begin credit: megatest's process.scm
-  (define (port->list fh )
-    (if (eof-object? fh) #f
-        (let loop ((curr (read-line fh))
-                   (result '()))
-          (if (not (eof-object? curr))
-              (loop (read-line fh)
-                    (append result (list curr)))
-              result))))
-
-  (define (conservative-read port)
-    (let loop ((res ""))
-      (if (not (eof-object? (peek-char port)))
-          (loop (conc res (read-char port)))
-          res)))
-  ;; end credit: megatest's process.scm
-
-  (define (counter-maker)
-    (let ((acc 0))
-      (lambda ( #!optional (increment 1) )
-        (set! acc (+ increment acc))
-        acc)))
-
-  (define (port->string port #!optional ) ; todo - add newline 
-    (let ((linelist (port->list port)))
-      (if linelist
-          (string-join linelist "\n")
-          "")))
-
-
-  (define (outport->foreach outport foreach-thunk)
-    (let loop ((line (foreach-thunk)))
-      (if line
-          (begin
-            (write-line line outport)
-            (loop (foreach-thunk))
-            )
-          (begin
-            ;;http://bugs.call-cc.org/ticket/766
-            ;;close-[input|output]-port implicitly calling process-wait on process pipe ports. This leads to errors like
-            ;;Error: (process-wait) waiting for child process failed - No child processes: 10872
-            (close-output-port outport)
-            #f))))
-  
-  ;; weird - alist-ref arg order changes signature csc vs. csi... explitly defining.
-  (define (my-alist-ref key alist)
-    (let ((res (assoc key alist)))
-      (if res (cdr res) #f)))
-
-  (define (keyword-skim-alist args alist)
-    (let loop ((result-alist '()) (result-args args) (rest-alist alist))
-      (cond
-       ((null? rest-alist) (values result-alist result-args))
-       (else
-        (let ((keyword (caar rest-alist))
-              (defval (cdar rest-alist)))
-          (let-values (((kwval result-args2)
-                        (keyword-skim
-                         keyword
-                         defval
-                         result-args)))
-            (loop
-             (cons (cons keyword kwval) result-alist)
-             result-args2
-             (cdr rest-alist))))))))
-  
-  (define (isys command . rest-args)
-    (let-values
-        (((opt-alist args)
-          (keyword-skim-alist
-           rest-args
-           '( ( foreach-stdout-thunk: . #f )
-              ( foreach-stdin-thunk: . #f )
-              ( stdin-proc: . #f ) ) )))
-      (let* ((foreach-stdout-thunk
-              (my-alist-ref foreach-stdout-thunk: opt-alist))
-             (foreach-stdin-thunk
-              (my-alist-ref foreach-stdin-thunk: opt-alist))
-             (stdin-proc
-              (if foreach-stdin-thunk
-                  (lambda (port)
-                    (outport->foreach port foreach-stdin-thunk))
-                  (my-alist-ref stdin-proc: opt-alist))))
-
-        ;; TODO: support command is list.
-        
-        (let-values (((stdout stdin pid stderr)
-                      (if (null? args)
-                          (process* command)
-                          (process* command args))))
-          
-                                        ;(if foreach-stdin-thunk
-                                        ;    (set! stdin-proc
-                                        ;          (lambda (port)
-                                        ;            (outport->foreach port foreach-stdin-thunk))))
-          
-          (if stdin-proc
-              (stdin-proc stdin))
-          
-          (let ((stdout-res 
-                 (if foreach-stdout-thunk  ;; don't accumulate stdout if we have a thunk; probably doing this because stdout is BIG so lets not waste memory
-                     (begin
-                       (port-for-each foreach-stdout-thunk (lambda () (read-line stdout)))
-                       "foreach-stdout-thunk ate stdout"
-                       )
-                     (if stdin-proc
-                         "foreach-stdin-thunk/stdin-proc blocks stdout"
-                         (port->string stdout))))
-                (stderr-res
-                 (if stdin-proc
-                     "foreach-stdin-thunk/stdin-proc blocks stdout"
-                     (port->string stderr))))
-
-            ;; if we've used a stdin-proc, we've closed stdin port, which unfortunately causes a wait-pid internally, causing stdout and stderr ports to auto-close.  don't close them again.  (so sad - we lost stdout and stderr contents when we write to stdin)
-            ;; see - http://bugs.call-cc.org/ticket/766
-            (if (not stdin-proc)
-                (close-input-port stdout)
-                (close-input-port stderr))
-            
-            (let-values (((anotherpid normalexit? exitstatus)  (process-wait pid)))
-              (values exitstatus stdout-res stderr-res)))))))
-  
-  (define (do-or-die command   #!key nodie (foreach-stdout #f) (stdin-proc #f))
-    (let-values (((exit-code stdout-str stderr-str) (isys command foreach-stdout-thunk: foreach-stdout stdin-proc: stdin-proc )))
-      (if (equal? 0 exit-code)
-          stdout-str
-          (begin
-            (ierr (conc "Command  > " command " "  "< failed with " exit-code " because: \n" stderr-str) )
-            (if nodie #f (exit exit-code))))))
-
-
-  ;; runs-ok: evaluate expression while suppressing exceptions.
-                                        ;    on caught exception, returns #f
-                                        ;    otherwise, returns expression value
-  (define (runs-ok thunk)
-    (handle-exceptions exn #f (begin (thunk) #t)))
-
-  ;; concat-lists: result list = lista + listb
-  (define (concat-lists lista listb) ;; ok, I just reimplemented append...
-    (foldr cons listb lista))
-  
-
-;;; setup general_lib env var parameters
-
-  ;; show warning/note/error/debug prefixes using ansi colors
-  (define ducttape-color-mode
-    (make-parameter (get-environment-variable "DUCTTAPE_COLORIZE")))
-
-  ;; if defined, has number value.  if number value > 0, show debug messages
-  ;; value should be decremented in subshells -- idea is raising debug level will show debug messages deeper and deeper in process call stack
-  (define ducttape-debug-level
-    (make-parameter
-     (let ( (raw-debug-level (get-environment-variable "DUCTTAPE_DEBUG_LEVEL")) )
-       (if raw-debug-level
-           (let ((num-debug-level (runs-ok (string->number raw-debug-level))))
-             (if (integer? num-debug-level)
-                 (begin
-                   (let ((new-num-debug-level (- num-debug-level 1)))
-                     (if (> new-num-debug-level 0) ;; decrement
-                         (setenv "DUCTTAPE_DEBUG_LEVEL" (number->string new-num-debug-level))
-                         (unsetenv "DUCTTAPE_DEBUG_LEVEL")))
-                   num-debug-level) ; it was set and > 0, mode is value
-                 (begin
-                   (unsetenv "DUCTTAPE_DEBUG_LEVEL") ;; value was invalid, unset it
-                   #f))) ; value was invalid, mode is f
-           #f)))) ; var not set, mode is f
-
-
-  (define ducttape-debug-mode (if (ducttape-debug-level)  #t  #f))
-
-  ;; ducttape-debug-regex-filter suppresses non-matching debug messages
-  (define ducttape-debug-regex-filter
-    (make-parameter
-     (let ((raw-debug-pattern (get-environment-variable "DUCTTAPE_DEBUG_PATTERN")))
-       (if raw-debug-pattern
-           raw-debug-pattern
-           "."))))
-
-  ;; silent mode suppresses Note and Warning type messages
-  (define ducttape-silent-mode
-    (make-parameter (get-environment-variable "DUCTTAPE_SILENT_MODE")))
-
-  ;; quiet mode suppresses Note type messages
-  (define ducttape-quiet-mode
-    (make-parameter (get-environment-variable "DUCTTAPE_QUIET_MODE")))
-
-  ;; if log file is defined, warning/note/error/debug messages are appended
-  ;; to named logfile.
-  (define ducttape-log-file
-    (make-parameter (get-environment-variable "DUCTTAPE_LOG_FILE")))
-
-
-
-
-  
-  
-;;; standard messages printing implementation
-
-                                        ; get the name of the current script/binary being run
-  (define (script-name)
-    (car (reverse (string-split (car (argv)) "/"))))
-
-  (define (ducttape-timestamp)
-    (rfc3339->string (time->rfc3339 (seconds->local-time))))
-
-
-  (define (iputs-preamble msg-type #!optional (suppress-color #f))
-    (let ((do-color (and
-                     (not suppress-color)
-                     (ducttape-color-mode)
-                     (terminal-port? (current-error-port)))))
-      (case msg-type
-        ((note)
-         (if do-color
-             (set-text (list 'fg-green 'bg-black 'bold) "Note:")
-             "Note:"
-             ))
-        ((warn)
-         (if do-color
-             (set-text (list 'fg-yellow 'bg-black 'bold) "Warning:")
-             "Warning:"
-             ))
-        ((err)
-         (if do-color
-             (set-text (list 'fg-red 'bg-black 'bold) "Error:")
-             "Error:"
-             ))
-        ((dbg)
-         (if do-color
-             (set-text (list 'fg-blue 'bg-magenta) "Debug:")
-             "Debug:"
-             )))))
-
-  (define (ducttape-append-logfile msg-type message #!optional (suppress-preamble #f))
-    (let
-        ((txt 
-          (string-join 
-           (list 
-            (ducttape-timestamp) 
-            (script-name)
-            (if suppress-preamble
-                message
-                (string-join  (list (iputs-preamble msg-type #t) message) " ")))
-           " | ")))
-
-      (if (ducttape-log-file)
-          (runs-ok
-           (call-with-output-file (ducttape-log-file)
-             (lambda (output-port)
-               (format output-port "~A ~%" txt)
-               )
-             #:append))
-          #t)))
-
-  (define (ducttape-activate-logfile #!optional (logfile #f))
-    ;; from python ducttape-lib.py
-                                        ; message = "START - pid=%d ppid=%d argv=(%s) pwd=%s user=%s host=%s"%(pid,ppid," ".join("'"+x+"'" for x in sys.argv),os.environ['PWD'],os.getenv('USER','nouser'),os.getenv('HOST','nohost') )
-    (let ((pid (number->string (current-process-id)))
-          (ppid (number->string (parent-process-id)))
-          (argv 
-           (string-join 
-            (map 
-             (lambda (x) 
-               (string-join (list "\"" x "\"")  "" ))
-             (argv))
-            " "))
-          (pwd (or (get-environment-variable "PWD") "nopwd"))
-          (user (or (get-environment-variable "USER") "nouser"))
-          (host (or (get-environment-variable "HOST") "nohost")))
-      (if logfile
-          (begin
-            (ducttape-log-file logfile)
-            (setenv "DUCTTAPE_LOG_FILE" (ducttape-log-file))))
-      (ducttape-append-logfile 'note (format #f "START - pid=~A ppid=~A argv=(~A) pwd=~A user=~A host=~A" pid ppid argv pwd user host) #t)))         
-
-
-  ;; log exit code
-  (define (set-ducttape-log-exit-handler)
-    (let ((orig-exit-handler (exit-handler)))
-      (exit-handler 
-       (lambda (exitcode) 
-         (ducttape-append-logfile 'note (format #f "Exit ~A by sys.exit" exitcode) #t)
-         (orig-exit-handler exitcode)))))
-
-
-  (define (idbg first-message  . rest-args)
-    (let* ((debug-level-threshold
-            (if (> (length rest-args) 0) (car rest-args) 1))
-           (message-list
-            (if (> (length rest-args) 1)
-                (cons first-message (cdr rest-args))
-                (list first-message)) )
-           (message (apply conc
-                  (map ->string message-list))))
-
-      (ducttape-append-logfile 'dbg message)
-      (if (ducttape-debug-level)
-          (if (<= debug-level-threshold (ducttape-debug-level))
-              (if (string-search (ducttape-debug-regex-filter) message)
-                  (begin 
-                    (format (current-error-port) "~A ~A (~A)~%" (iputs-preamble 'dbg) message (script-name))))))))
-
-  (define (ierr message-first  . message-rest)
-    (let* ((message
-            (apply conc
-             (map ->string (cons message-first message-rest)))))
-      (ducttape-append-logfile 'err message)
-      (format (current-error-port) "~A ~A (~A)~%" (iputs-preamble 'err) message (script-name))))
-
-  (define (iwarn message-first  . message-rest)
-    (let* ((message
-            (apply conc
-             (map ->string (cons message-first message-rest)))))
-      (ducttape-append-logfile 'warn message)
-      (if (not (ducttape-silent-mode))
-          (begin
-            (format (current-error-port) "~A ~A (~A)~%" (iputs-preamble 'warn) message (script-name))))))
-
-  (define (inote message-first  . message-rest)
-    (let* ((message
-            (apply conc
-             (map ->string (cons message-first message-rest)))))
-      (ducttape-append-logfile 'note message)
-      (if (not (or (ducttape-silent-mode) (ducttape-quiet-mode)))
-          (begin 
-            (format (current-error-port) "~A ~A (~A)~%" (iputs-preamble 'note) message (script-name))))))
-
-  
-  (define (iputs kind message #!optional (debug-level-threshold 1))
-    (cond
-     ((member kind (string-split "NOTE/Note/note/n/N" "/")) (inote message))
-     ((member kind (string-split "Error/ERROR/error/Err/ERR/err/E/e" "/")) (ierr message))
-     ((member kind
-              (string-split "Warning/WARNING/warning/Warn/WARN/warn/W/w" "/"))
-      (iwarn message))
-     ((member kind (string-split "Debug/DEBUG/debug/Dbg/DBG/dbg/D/d" "/"))
-      (idbg message debug-level-threshold))))
-
-  (define (mkdir-recursive path-so-far hier-list-to-create)
-    (if (null? hier-list-to-create)
-        path-so-far
-        (let* ((next-hier-item (car hier-list-to-create))
-               (rest-hier-items (cdr hier-list-to-create))
-               (path-to-mkdir (string-concatenate (list path-so-far "/" next-hier-item))))
-          (if (runs-ok (lambda () (create-directory path-to-mkdir)))
-              (mkdir-recursive path-to-mkdir rest-hier-items)
-              #f))))
-
-                                        ; ::mkdir-if-not-exists::
-                                        ; make a dir recursively if it does not 
-                                        ; already exist.
-                                        ; on success - returns path
-                                        ; on fail - returns #f
-  (define (mkdirp-if-not-exists the-dir)
-    (let ( (path-list (string-split the-dir "/")))
-      (mkdir-recursive "/" path-list)))
-
-                                        ; ::mkdir-if-not-exists::
-                                        ; make a dir recursively if it does not 
-                                        ; already exist.
-                                        ; on success - returns path
-                                        ; on fail - returns #f
-
-
-  (define (mkdirp-if-not-exists the-dir)
-    (let ( (path-list (string-split the-dir "/")))
-      (mkdir-recursive "/" path-list)))
-
-  (define (dir-is-writable? the-dir)
-    (let ((dummy-file (string-concatenate (list the-dir "/.dummyfile"))))
-      (and
-       (file-exists? the-dir)
-       (cond 
-        ((runs-ok (lambda ()(with-output-to-file dummy-file (lambda () (print "foo")))))
-         (begin
-           (runs-ok (lambda () (delete-file dummy-file) ))
-           the-dir))
-        (else #f)))))
-
-
-  (define (get-tmpdir )
-    (let* ((tmproot
-            (dir-is-writable?
-             (or 
-              (get-environment-variable "TMPDIR") 
-              "/tmp")))
-
-           (user
-            (or
-             (get-environment-variable "USER")
-             "USER_Envvar_not_set"))
-           (tmppath
-            (string-concatenate 
-             (list tmproot "/env21-general-" user ))))
-
-      (dir-is-writable?
-       (mkdirp-if-not-exists
-        tmppath))))
-
-  (define (mktemp
-           #!optional
-           (prefix "general_lib_tmpfile")
-           (dir #f))
-    (let-values
-        (((fd path) 
-          (file-mkstemp 
-           (conc 
-            (if dir  dir  (get-tmpdir))
-            "/" prefix ".XXXXXX"))))
-      (close-output-port (open-output-file* fd))
-      path))
-
-
-
-  ;;http://stackoverflow.com/questions/11134857/using-sendmail-for-html-body-and-binary-attachment
-  ;; write send-email using:
-  ;;   - isys-foreach-stdin-line
-  ;;   - formatting in http://stackoverflow.com/questions/11134857/using-sendmail-for-html-body-and-binary-attachment
-  (define (sendmail to_addr subject body
-                    #!key
-                    (from_addr "admin")
-                    cc_addr
-                    bcc_addr
-                    more-headers
-                    use_html
-                    (attach-files-list '())
-                    (images-with-content-id-alist '())
-                    )
-
-    (define (sendmail-proc sendmail-port)
-      (define (wl line-str)
-        (write-line line-str sendmail-port))
-
-      (define (get-uuid)
-        (string-upcase (uuid->string (uuid-generate))))
-
-      (let ((mailpart-uuid (get-uuid))
-            (mailpart-body-uuid (get-uuid)))
-        
-        (define (boundary)
-          (wl (conc "--" mailpart-uuid)))
-
-        (define (body-boundary)
-          (wl (conc "--" mailpart-body-uuid)))
-
-
-        (define (email-mime-header)
-          (wl (conc "From: " from_addr))
-          (wl (conc "To: " to_addr))
-          (if cc_addr
-              (wl (conc "Cc: " cc_addr)))
-          (if bcc_addr
-              (wl (conc "Bcc: " bcc_addr)))
-          (if more-headers
-              (wl more-headers))
-          (wl (conc "Subject: " subject))
-          (wl "MIME-Version: 1.0")
-          (wl (conc "Content-Type: multipart/mixed; boundary=\"" mailpart-uuid "\""))
-          (wl "")
-          (boundary)
-          (wl (conc "Content-Type: multipart/alternative; boundary=\"" mailpart-body-uuid "\""))
-          (wl "")
-          )
-
-        
-        (define (email-text-body)
-          (body-boundary)
-          (wl "Content-Type: text/plain; charset=ISO-8859-1")
-          (wl "Content-Disposition: inline")
-          (wl "")
-          (wl body)
-          (body-boundary))
-        
-        (define (email-html-body)
-          (body-boundary)
-          (wl "Content-Type: text/plain; charset=ISO-8859-1")
-          (wl "")
-          (wl "You need to enable HTML option for email")
-          (body-boundary)
-          (wl "Content-Type: text/html; charset=ISO-8859-1")
-          (wl "Content-Disposition: inline")
-          (wl "")
-          (wl body)
-          (body-boundary))
-
-        (define (attach-file file #!key (content-id #f))
-          (let* ((filename
-                  (filepath:take-file-name file))
-                 (ext-with-dot
-                  (filepath:take-extension file))
-                 (ext (string-take-right
-                       ext-with-dot
-                       (- (string-length ext-with-dot) 1)))
-                 (mimetype (ext->mimetype ext))
-                 (uuencode-command (conc "uuencode " file " " filename)))
-            (boundary)
-            (wl (conc "Content-Type: " mimetype "; name=\"" filename "\""))
-            (wl "Content-Transfer-Encoding: uuencode")
-            (if content-id
-                (wl (conc "Content-Id: " content-id)))
-            (wl (conc "Content-Disposition: attachment; filename=\"" filename "\""))
-            (wl "")
-            (do-or-die
-             uuencode-command
-             foreach-stdout:
-             (lambda (line)
-               (wl line)))))
-
-        (define (embed-image file+content-id)
-          (let ((file (car file+content-id))
-                (content-id (cdr file+content-id)))
-            (attach-file file content-id: content-id)))
-        
-        ;; send the email
-        (email-mime-header)
-        (if use_html
-            (email-html-body)
-            (email-text-body))
-        (for-each attach-file attach-files-list)
-        (for-each embed-image images-with-content-id-alist)
-        (boundary)
-        (close-output-port sendmail-port)))
-    
-    (do-or-die "/usr/sbin/sendmail -t"
-               stdin-proc: sendmail-proc))
-
-  ;; like shell "which" command
-  (define (find-exe exe)
-    (let* ((path-items
-            (string-split
-             (or
-              (get-environment-variable "PATH") "")
-             ":")))
-
-      (let loop ((rest-path-items path-items))
-        (if (null? rest-path-items)
-            #f
-            (let* ((this-dir (car rest-path-items))
-                   (next-rest (cdr rest-path-items))
-                   (candidate (conc this-dir "/" exe)))
-              (if (file-execute-access? candidate)
-                  candidate
-                  (loop next-rest)))))))
-
-
-;;;; process command line options
-
-  ;; get command line switches (have no subsequent arg; eg. [-foo])
-  ;;  assumes these are switches without arguments
-  ;;  will return list of matches
-  ;;  removes matches from command-line-arguments parameter
-  (define (skim-cmdline-opts-noarg-by-regex switch-pattern)
-    (let* (
-           (irr (irregex switch-pattern))
-           (matches (filter
-                     (lambda (x)
-                       (irregex-match irr x))
-                     (command-line-arguments)))
-           (non-matches (filter
-                         (lambda (x)
-                           (not (member x matches)))
-                         (command-line-arguments))))
-
-      (command-line-arguments non-matches)
-      matches))
-
-  (define (keyword-skim keyword default args #!optional (eqpred equal?))
-    (let loop ( (kwval default) (args-remaining args) (args-to-return '()) )
-      (cond 
-       ((null? args-remaining)
-        (values
-         (if (list? kwval) (reverse kwval) kwval)
-         (reverse args-to-return)))
-       ((and (> (length args-remaining) 1) (eqpred keyword (car args-remaining)))
-        (if (list? default)
-            (if (equal? default kwval)
-                (loop (list (cadr args-remaining)) (cddr args-remaining) args-to-return)
-                (loop (cons (cadr args-remaining) kwval) (cddr args-remaining) args-to-return))
-            (loop (cadr args-remaining) (cddr args-remaining) args-to-return)))
-       (else (loop kwval (cdr args-remaining) (cons (car args-remaining) args-to-return))))))
-
-
-
-  ;; get command line switches (have a subsequent arg; eg. [-foo bar])
-  ;;  assumes these are switches without arguments
-  ;;  will return list of arguments to matches
-  ;;  removes matches from command-line-arguments parameter
-
-  (define (re-match? re str)
-    (irregex-match re str))
-
-  (define (skim-cmdline-opts-withargs-by-regex switch-pattern)
-    (let-values
-        (((result new-cmdline-args)
-          (keyword-skim switch-pattern
-                        '()
-                        (command-line-arguments)
-                        re-match?
-                        )))
-      (command-line-arguments new-cmdline-args)
-      result))
-  
-  
-
-  ;; recognize ducttape-lib command line switches (--quiet, --silent, --color, -d.., -dp.., -logfile)
-  ;;    - reset parameters; reset DUCTTAPE_* env vars to match user specified intent
-  ;;    - mutate (command-line-arguments) parameter to subtract these recognized and handled switches
-  ;;       * beware -- now (argv) and (command-line-arguments) are inconsistent... cannot mutate (argv) alas.  Use (command-line-arguments)
-  ;; WARNING: this defines command line arguments that may clash with your program.  Only call this if you
-  ;; are sure they can coexist.
-  (define (ducttape-process-command-line)
-
-    ;; --quiet
-    (let ((quiet-opts (skim-cmdline-opts-noarg-by-regex "--?quiet")))
-      (if (not (null? quiet-opts))
-          (begin
-            (setenv "DUCTTAPE_QUIET_MODE" "1")
-            (ducttape-quiet-mode "1"))))
-
-    ;; --silent
-    (let ((silent-opts (skim-cmdline-opts-noarg-by-regex "--?silent")))
-      (if (not (null? silent-opts))
-          (begin
-            (setenv "DUCTTAPE_SILENT_MODE" "1")
-            (ducttape-silent-mode "1"))))
-
-    ;; -color
-    (let ((color-opts (skim-cmdline-opts-noarg-by-regex "--?colou?r(ize)?")))
-      (if (not (null? color-opts))
-          (begin
-            (setenv "DUCTTAPE_COLORIZE" "1")
-            (ducttape-color-mode "1"))))
-
-    ;; -nocolor
-    (let ((nocolor-opts (skim-cmdline-opts-noarg-by-regex "--?nocolou?r(ize)?")))
-      (if (not (null? nocolor-opts))
-          (begin
-            (unsetenv "DUCTTAPE_COLORIZE" )
-            (ducttape-color-mode #f))))
-
-    ;; -logfile
-    (let ((logfile-opts (skim-cmdline-opts-withargs-by-regex "--?log(-?file)?")))
-      (if (not (null? logfile-opts))
-          (begin
-            (ducttape-log-file (car (reverse logfile-opts)))
-            (setenv "DUCTTAPE_LOG_FILE" (ducttape-log-file)))))
-
-    ;; -d -dd -d#
-    (let ((debug-opts (skim-cmdline-opts-noarg-by-regex "-d(d*|\\d+)"))
-          (initial-debuglevel (if (ducttape-debug-level) (ducttape-debug-level) 0) ))
-      (if (not (null? debug-opts))
-          (begin
-            (ducttape-debug-level
-             (let loop ((opts debug-opts) (debuglevel initial-debuglevel))
-               (if (null? opts)
-                   debuglevel
-                   (let*
-                       ( (curopt (car opts))
-                         (restopts (cdr opts))
-                         (ds (string-match "-(d+)" curopt))
-                         (dnum (string-match "-d(\\d+)" curopt)))
-                     (cond
-                      (ds (loop restopts (+ debuglevel (string-length (cadr ds)))))
-                      (dnum  (loop restopts (string->number (cadr dnum)))))))))
-            (setenv "DUCTTAPE_DEBUG_LEVEL" (number->string (ducttape-debug-level))))))
-
-
-    ;; -dp  / --debug-pattern 
-    (let ((debugpat-opts (skim-cmdline-opts-withargs-by-regex "--?(debug-pattern|dp)")))
-      (if (not (null? debugpat-opts))
-          (begin
-            (ducttape-debug-regex-filter (string-join debugpat-opts "|"))
-            (setenv "DUCTTAPE_DEBUG_PATTERN" (ducttape-debug-regex-filter)))))) 
-
-
-  ;;; following code commented out; side effects not wanted on startup
-  ;; immediately activate logfile (will be noop if logfile disabled)
-  ;;(ducttape-activate-logfile)
-  ;;(set-ducttape-log-exit-handler)
-  
-  ;; TODO: hook exception handler so we can log exception before we sign off.
-
-  ;; handle command line immediately; 
-  ;;(process-command-line)                    
-
-
-  ) ; end module

DELETED ducttape/ducttape-lib.setup
Index: ducttape/ducttape-lib.setup
==================================================================
--- ducttape/ducttape-lib.setup
+++ /dev/null
@@ -1,1 +0,0 @@
-(standard-extension 'ducttape-lib '1.0.0)

DELETED ducttape/mimetypes.scm
Index: ducttape/mimetypes.scm
==================================================================
--- ducttape/mimetypes.scm
+++ /dev/null
@@ -1,782 +0,0 @@
-;; gathered from macosx:
-;;   cat /etc/apache2/mime.types | grep -v '^#' | perl -ne 'print "(\"$2\" . \"$1\")\n" if /(\S+)\s+(\S+)/' > mimetypes.scm
-;; + manual manipulation
-
-(define ducttape_ext2mimetype '(("ez" . "application/andrew-inset")
-("aw" . "application/applixware")
-("atom" . "application/atom+xml")
-("atomcat" . "application/atomcat+xml")
-("atomsvc" . "application/atomsvc+xml")
-("ccxml" . "application/ccxml+xml")
-("cdmia" . "application/cdmi-capability")
-("cdmic" . "application/cdmi-container")
-("cdmid" . "application/cdmi-domain")
-("cdmio" . "application/cdmi-object")
-("cdmiq" . "application/cdmi-queue")
-("cu" . "application/cu-seeme")
-("davmount" . "application/davmount+xml")
-("dbk" . "application/docbook+xml")
-("dssc" . "application/dssc+der")
-("xdssc" . "application/dssc+xml")
-("ecma" . "application/ecmascript")
-("emma" . "application/emma+xml")
-("epub" . "application/epub+zip")
-("exi" . "application/exi")
-("pfr" . "application/font-tdpfr")
-("gml" . "application/gml+xml")
-("gpx" . "application/gpx+xml")
-("gxf" . "application/gxf")
-("stk" . "application/hyperstudio")
-("ink" . "application/inkml+xml")
-("ipfix" . "application/ipfix")
-("jar" . "application/java-archive")
-("ser" . "application/java-serialized-object")
-("class" . "application/java-vm")
-("js" . "application/javascript")
-("json" . "application/json")
-("jsonml" . "application/jsonml+json")
-("lostxml" . "application/lost+xml")
-("hqx" . "application/mac-binhex40")
-("cpt" . "application/mac-compactpro")
-("mads" . "application/mads+xml")
-("mrc" . "application/marc")
-("mrcx" . "application/marcxml+xml")
-("ma" . "application/mathematica")
-("mathml" . "application/mathml+xml")
-("mbox" . "application/mbox")
-("mscml" . "application/mediaservercontrol+xml")
-("metalink" . "application/metalink+xml")
-("meta4" . "application/metalink4+xml")
-("mets" . "application/mets+xml")
-("mods" . "application/mods+xml")
-("m21" . "application/mp21")
-("mp4s" . "application/mp4")
-("doc" . "application/msword")
-("mxf" . "application/mxf")
-("bin" . "application/octet-stream")
-("oda" . "application/oda")
-("opf" . "application/oebps-package+xml")
-("ogx" . "application/ogg")
-("omdoc" . "application/omdoc+xml")
-("onetoc" . "application/onenote")
-("oxps" . "application/oxps")
-("xer" . "application/patch-ops-error+xml")
-("pdf" . "application/pdf")
-("pgp" . "application/pgp-encrypted")
-("asc" . "application/pgp-signature")
-("prf" . "application/pics-rules")
-("p10" . "application/pkcs10")
-("p7m" . "application/pkcs7-mime")
-("p7s" . "application/pkcs7-signature")
-("p8" . "application/pkcs8")
-("ac" . "application/pkix-attr-cert")
-("cer" . "application/pkix-cert")
-("crl" . "application/pkix-crl")
-("pkipath" . "application/pkix-pkipath")
-("pki" . "application/pkixcmp")
-("pls" . "application/pls+xml")
-("ai" . "application/postscript")
-("cww" . "application/prs.cww")
-("pskcxml" . "application/pskc+xml")
-("rdf" . "application/rdf+xml")
-("rif" . "application/reginfo+xml")
-("rnc" . "application/relax-ng-compact-syntax")
-("rl" . "application/resource-lists+xml")
-("rld" . "application/resource-lists-diff+xml")
-("rs" . "application/rls-services+xml")
-("gbr" . "application/rpki-ghostbusters")
-("mft" . "application/rpki-manifest")
-("roa" . "application/rpki-roa")
-("rsd" . "application/rsd+xml")
-("rss" . "application/rss+xml")
-("rtf" . "application/rtf")
-("sbml" . "application/sbml+xml")
-("scq" . "application/scvp-cv-request")
-("scs" . "application/scvp-cv-response")
-("spq" . "application/scvp-vp-request")
-("spp" . "application/scvp-vp-response")
-("sdp" . "application/sdp")
-("setpay" . "application/set-payment-initiation")
-("setreg" . "application/set-registration-initiation")
-("shf" . "application/shf+xml")
-("smi" . "application/smil+xml")
-("rq" . "application/sparql-query")
-("srx" . "application/sparql-results+xml")
-("gram" . "application/srgs")
-("grxml" . "application/srgs+xml")
-("sru" . "application/sru+xml")
-("ssdl" . "application/ssdl+xml")
-("ssml" . "application/ssml+xml")
-("tei" . "application/tei+xml")
-("tfi" . "application/thraud+xml")
-("tsd" . "application/timestamped-data")
-("plb" . "application/vnd.3gpp.pic-bw-large")
-("psb" . "application/vnd.3gpp.pic-bw-small")
-("pvb" . "application/vnd.3gpp.pic-bw-var")
-("tcap" . "application/vnd.3gpp2.tcap")
-("pwn" . "application/vnd.3m.post-it-notes")
-("aso" . "application/vnd.accpac.simply.aso")
-("imp" . "application/vnd.accpac.simply.imp")
-("acu" . "application/vnd.acucobol")
-("atc" . "application/vnd.acucorp")
-("air" . "application/vnd.adobe.air-application-installer-package+zip")
-("fcdt" . "application/vnd.adobe.formscentral.fcdt")
-("fxp" . "application/vnd.adobe.fxp")
-("xdp" . "application/vnd.adobe.xdp+xml")
-("xfdf" . "application/vnd.adobe.xfdf")
-("ahead" . "application/vnd.ahead.space")
-("azf" . "application/vnd.airzip.filesecure.azf")
-("azs" . "application/vnd.airzip.filesecure.azs")
-("azw" . "application/vnd.amazon.ebook")
-("acc" . "application/vnd.americandynamics.acc")
-("ami" . "application/vnd.amiga.ami")
-("apk" . "application/vnd.android.package-archive")
-("cii" . "application/vnd.anser-web-certificate-issue-initiation")
-("fti" . "application/vnd.anser-web-funds-transfer-initiation")
-("atx" . "application/vnd.antix.game-component")
-("mpkg" . "application/vnd.apple.installer+xml")
-("m3u8" . "application/vnd.apple.mpegurl")
-("swi" . "application/vnd.aristanetworks.swi")
-("iota" . "application/vnd.astraea-software.iota")
-("aep" . "application/vnd.audiograph")
-("mpm" . "application/vnd.blueice.multipass")
-("bmi" . "application/vnd.bmi")
-("rep" . "application/vnd.businessobjects")
-("cdxml" . "application/vnd.chemdraw+xml")
-("mmd" . "application/vnd.chipnuts.karaoke-mmd")
-("cdy" . "application/vnd.cinderella")
-("cla" . "application/vnd.claymore")
-("rp9" . "application/vnd.cloanto.rp9")
-("c4g" . "application/vnd.clonk.c4group")
-("c11amc" . "application/vnd.cluetrust.cartomobile-config")
-("c11amz" . "application/vnd.cluetrust.cartomobile-config-pkg")
-("csp" . "application/vnd.commonspace")
-("cdbcmsg" . "application/vnd.contact.cmsg")
-("cmc" . "application/vnd.cosmocaller")
-("clkx" . "application/vnd.crick.clicker")
-("clkk" . "application/vnd.crick.clicker.keyboard")
-("clkp" . "application/vnd.crick.clicker.palette")
-("clkt" . "application/vnd.crick.clicker.template")
-("clkw" . "application/vnd.crick.clicker.wordbank")
-("wbs" . "application/vnd.criticaltools.wbs+xml")
-("pml" . "application/vnd.ctc-posml")
-("ppd" . "application/vnd.cups-ppd")
-("car" . "application/vnd.curl.car")
-("pcurl" . "application/vnd.curl.pcurl")
-("dart" . "application/vnd.dart")
-("rdz" . "application/vnd.data-vision.rdz")
-("uvf" . "application/vnd.dece.data")
-("uvt" . "application/vnd.dece.ttml+xml")
-("uvx" . "application/vnd.dece.unspecified")
-("uvz" . "application/vnd.dece.zip")
-("fe_launch" . "application/vnd.denovo.fcselayout-link")
-("dna" . "application/vnd.dna")
-("mlp" . "application/vnd.dolby.mlp")
-("dpg" . "application/vnd.dpgraph")
-("dfac" . "application/vnd.dreamfactory")
-("kpxx" . "application/vnd.ds-keypoint")
-("ait" . "application/vnd.dvb.ait")
-("svc" . "application/vnd.dvb.service")
-("geo" . "application/vnd.dynageo")
-("mag" . "application/vnd.ecowin.chart")
-("nml" . "application/vnd.enliven")
-("esf" . "application/vnd.epson.esf")
-("msf" . "application/vnd.epson.msf")
-("qam" . "application/vnd.epson.quickanime")
-("slt" . "application/vnd.epson.salt")
-("ssf" . "application/vnd.epson.ssf")
-("es3" . "application/vnd.eszigno3+xml")
-("ez2" . "application/vnd.ezpix-album")
-("ez3" . "application/vnd.ezpix-package")
-("fdf" . "application/vnd.fdf")
-("mseed" . "application/vnd.fdsn.mseed")
-("seed" . "application/vnd.fdsn.seed")
-("gph" . "application/vnd.flographit")
-("ftc" . "application/vnd.fluxtime.clip")
-("fm" . "application/vnd.framemaker")
-("fnc" . "application/vnd.frogans.fnc")
-("ltf" . "application/vnd.frogans.ltf")
-("fsc" . "application/vnd.fsc.weblaunch")
-("oas" . "application/vnd.fujitsu.oasys")
-("oa2" . "application/vnd.fujitsu.oasys2")
-("oa3" . "application/vnd.fujitsu.oasys3")
-("fg5" . "application/vnd.fujitsu.oasysgp")
-("bh2" . "application/vnd.fujitsu.oasysprs")
-("ddd" . "application/vnd.fujixerox.ddd")
-("xdw" . "application/vnd.fujixerox.docuworks")
-("xbd" . "application/vnd.fujixerox.docuworks.binder")
-("fzs" . "application/vnd.fuzzysheet")
-("txd" . "application/vnd.genomatix.tuxedo")
-("ggb" . "application/vnd.geogebra.file")
-("ggt" . "application/vnd.geogebra.tool")
-("gex" . "application/vnd.geometry-explorer")
-("gxt" . "application/vnd.geonext")
-("g2w" . "application/vnd.geoplan")
-("g3w" . "application/vnd.geospace")
-("gmx" . "application/vnd.gmx")
-("kml" . "application/vnd.google-earth.kml+xml")
-("kmz" . "application/vnd.google-earth.kmz")
-("gqf" . "application/vnd.grafeq")
-("gac" . "application/vnd.groove-account")
-("ghf" . "application/vnd.groove-help")
-("gim" . "application/vnd.groove-identity-message")
-("grv" . "application/vnd.groove-injector")
-("gtm" . "application/vnd.groove-tool-message")
-("tpl" . "application/vnd.groove-tool-template")
-("vcg" . "application/vnd.groove-vcard")
-("hal" . "application/vnd.hal+xml")
-("zmm" . "application/vnd.handheld-entertainment+xml")
-("hbci" . "application/vnd.hbci")
-("les" . "application/vnd.hhe.lesson-player")
-("hpgl" . "application/vnd.hp-hpgl")
-("hpid" . "application/vnd.hp-hpid")
-("hps" . "application/vnd.hp-hps")
-("jlt" . "application/vnd.hp-jlyt")
-("pcl" . "application/vnd.hp-pcl")
-("pclxl" . "application/vnd.hp-pclxl")
-("sfd-hdstx" . "application/vnd.hydrostatix.sof-data")
-("mpy" . "application/vnd.ibm.minipay")
-("afp" . "application/vnd.ibm.modcap")
-("irm" . "application/vnd.ibm.rights-management")
-("sc" . "application/vnd.ibm.secure-container")
-("icc" . "application/vnd.iccprofile")
-("igl" . "application/vnd.igloader")
-("ivp" . "application/vnd.immervision-ivp")
-("ivu" . "application/vnd.immervision-ivu")
-("igm" . "application/vnd.insors.igm")
-("xpw" . "application/vnd.intercon.formnet")
-("i2g" . "application/vnd.intergeo")
-("qbo" . "application/vnd.intu.qbo")
-("qfx" . "application/vnd.intu.qfx")
-("rcprofile" . "application/vnd.ipunplugged.rcprofile")
-("irp" . "application/vnd.irepository.package+xml")
-("xpr" . "application/vnd.is-xpr")
-("fcs" . "application/vnd.isac.fcs")
-("jam" . "application/vnd.jam")
-("rms" . "application/vnd.jcp.javame.midlet-rms")
-("jisp" . "application/vnd.jisp")
-("joda" . "application/vnd.joost.joda-archive")
-("ktz" . "application/vnd.kahootz")
-("karbon" . "application/vnd.kde.karbon")
-("chrt" . "application/vnd.kde.kchart")
-("kfo" . "application/vnd.kde.kformula")
-("flw" . "application/vnd.kde.kivio")
-("kon" . "application/vnd.kde.kontour")
-("kpr" . "application/vnd.kde.kpresenter")
-("ksp" . "application/vnd.kde.kspread")
-("kwd" . "application/vnd.kde.kword")
-("htke" . "application/vnd.kenameaapp")
-("kia" . "application/vnd.kidspiration")
-("kne" . "application/vnd.kinar")
-("skp" . "application/vnd.koan")
-("sse" . "application/vnd.kodak-descriptor")
-("lasxml" . "application/vnd.las.las+xml")
-("lbd" . "application/vnd.llamagraphics.life-balance.desktop")
-("lbe" . "application/vnd.llamagraphics.life-balance.exchange+xml")
-("123" . "application/vnd.lotus-1-2-3")
-("apr" . "application/vnd.lotus-approach")
-("pre" . "application/vnd.lotus-freelance")
-("nsf" . "application/vnd.lotus-notes")
-("org" . "application/vnd.lotus-organizer")
-("scm" . "application/vnd.lotus-screencam")
-("lwp" . "application/vnd.lotus-wordpro")
-("portpkg" . "application/vnd.macports.portpkg")
-("mcd" . "application/vnd.mcd")
-("mc1" . "application/vnd.medcalcdata")
-("cdkey" . "application/vnd.mediastation.cdkey")
-("mwf" . "application/vnd.mfer")
-("mfm" . "application/vnd.mfmp")
-("flo" . "application/vnd.micrografx.flo")
-("igx" . "application/vnd.micrografx.igx")
-("mif" . "application/vnd.mif")
-("daf" . "application/vnd.mobius.daf")
-("dis" . "application/vnd.mobius.dis")
-("mbk" . "application/vnd.mobius.mbk")
-("mqy" . "application/vnd.mobius.mqy")
-("msl" . "application/vnd.mobius.msl")
-("plc" . "application/vnd.mobius.plc")
-("txf" . "application/vnd.mobius.txf")
-("mpn" . "application/vnd.mophun.application")
-("mpc" . "application/vnd.mophun.certificate")
-("xul" . "application/vnd.mozilla.xul+xml")
-("cil" . "application/vnd.ms-artgalry")
-("cab" . "application/vnd.ms-cab-compressed")
-("xls" . "application/vnd.ms-excel")
-("xlam" . "application/vnd.ms-excel.addin.macroenabled.12")
-("xlsb" . "application/vnd.ms-excel.sheet.binary.macroenabled.12")
-("xlsm" . "application/vnd.ms-excel.sheet.macroenabled.12")
-("xltm" . "application/vnd.ms-excel.template.macroenabled.12")
-("eot" . "application/vnd.ms-fontobject")
-("chm" . "application/vnd.ms-htmlhelp")
-("ims" . "application/vnd.ms-ims")
-("lrm" . "application/vnd.ms-lrm")
-("thmx" . "application/vnd.ms-officetheme")
-("cat" . "application/vnd.ms-pki.seccat")
-("stl" . "application/vnd.ms-pki.stl")
-("ppt" . "application/vnd.ms-powerpoint")
-("ppam" . "application/vnd.ms-powerpoint.addin.macroenabled.12")
-("pptm" . "application/vnd.ms-powerpoint.presentation.macroenabled.12")
-("sldm" . "application/vnd.ms-powerpoint.slide.macroenabled.12")
-("ppsm" . "application/vnd.ms-powerpoint.slideshow.macroenabled.12")
-("potm" . "application/vnd.ms-powerpoint.template.macroenabled.12")
-("mpp" . "application/vnd.ms-project")
-("docm" . "application/vnd.ms-word.document.macroenabled.12")
-("dotm" . "application/vnd.ms-word.template.macroenabled.12")
-("wps" . "application/vnd.ms-works")
-("wpl" . "application/vnd.ms-wpl")
-("xps" . "application/vnd.ms-xpsdocument")
-("mseq" . "application/vnd.mseq")
-("mus" . "application/vnd.musician")
-("msty" . "application/vnd.muvee.style")
-("taglet" . "application/vnd.mynfc")
-("nlu" . "application/vnd.neurolanguage.nlu")
-("ntf" . "application/vnd.nitf")
-("nnd" . "application/vnd.noblenet-directory")
-("nns" . "application/vnd.noblenet-sealer")
-("nnw" . "application/vnd.noblenet-web")
-("ngdat" . "application/vnd.nokia.n-gage.data")
-("n-gage" . "application/vnd.nokia.n-gage.symbian.install")
-("rpst" . "application/vnd.nokia.radio-preset")
-("rpss" . "application/vnd.nokia.radio-presets")
-("edm" . "application/vnd.novadigm.edm")
-("edx" . "application/vnd.novadigm.edx")
-("ext" . "application/vnd.novadigm.ext")
-("odc" . "application/vnd.oasis.opendocument.chart")
-("otc" . "application/vnd.oasis.opendocument.chart-template")
-("odb" . "application/vnd.oasis.opendocument.database")
-("odf" . "application/vnd.oasis.opendocument.formula")
-("odft" . "application/vnd.oasis.opendocument.formula-template")
-("odg" . "application/vnd.oasis.opendocument.graphics")
-("otg" . "application/vnd.oasis.opendocument.graphics-template")
-("odi" . "application/vnd.oasis.opendocument.image")
-("oti" . "application/vnd.oasis.opendocument.image-template")
-("odp" . "application/vnd.oasis.opendocument.presentation")
-("otp" . "application/vnd.oasis.opendocument.presentation-template")
-("ods" . "application/vnd.oasis.opendocument.spreadsheet")
-("ots" . "application/vnd.oasis.opendocument.spreadsheet-template")
-("odt" . "application/vnd.oasis.opendocument.text")
-("odm" . "application/vnd.oasis.opendocument.text-master")
-("ott" . "application/vnd.oasis.opendocument.text-template")
-("oth" . "application/vnd.oasis.opendocument.text-web")
-("xo" . "application/vnd.olpc-sugar")
-("dd2" . "application/vnd.oma.dd2+xml")
-("oxt" . "application/vnd.openofficeorg.extension")
-("pptx" . "application/vnd.openxmlformats-officedocument.presentationml.presentation")
-("sldx" . "application/vnd.openxmlformats-officedocument.presentationml.slide")
-("ppsx" . "application/vnd.openxmlformats-officedocument.presentationml.slideshow")
-("potx" . "application/vnd.openxmlformats-officedocument.presentationml.template")
-("xlsx" . "application/vnd.openxmlformats-officedocument.spreadsheetml.sheet")
-("xltx" . "application/vnd.openxmlformats-officedocument.spreadsheetml.template")
-("docx" . "application/vnd.openxmlformats-officedocument.wordprocessingml.document")
-("dotx" . "application/vnd.openxmlformats-officedocument.wordprocessingml.template")
-("mgp" . "application/vnd.osgeo.mapguide.package")
-("dp" . "application/vnd.osgi.dp")
-("esa" . "application/vnd.osgi.subsystem")
-("pdb" . "application/vnd.palm")
-("paw" . "application/vnd.pawaafile")
-("str" . "application/vnd.pg.format")
-("ei6" . "application/vnd.pg.osasli")
-("efif" . "application/vnd.picsel")
-("wg" . "application/vnd.pmi.widget")
-("plf" . "application/vnd.pocketlearn")
-("pbd" . "application/vnd.powerbuilder6")
-("box" . "application/vnd.previewsystems.box")
-("mgz" . "application/vnd.proteus.magazine")
-("qps" . "application/vnd.publishare-delta-tree")
-("ptid" . "application/vnd.pvi.ptid1")
-("qxd" . "application/vnd.quark.quarkxpress")
-("bed" . "application/vnd.realvnc.bed")
-("mxl" . "application/vnd.recordare.musicxml")
-("musicxml" . "application/vnd.recordare.musicxml+xml")
-("cryptonote" . "application/vnd.rig.cryptonote")
-("cod" . "application/vnd.rim.cod")
-("rm" . "application/vnd.rn-realmedia")
-("rmvb" . "application/vnd.rn-realmedia-vbr")
-("link66" . "application/vnd.route66.link66+xml")
-("st" . "application/vnd.sailingtracker.track")
-("see" . "application/vnd.seemail")
-("sema" . "application/vnd.sema")
-("semd" . "application/vnd.semd")
-("semf" . "application/vnd.semf")
-("ifm" . "application/vnd.shana.informed.formdata")
-("itp" . "application/vnd.shana.informed.formtemplate")
-("iif" . "application/vnd.shana.informed.interchange")
-("ipk" . "application/vnd.shana.informed.package")
-("twd" . "application/vnd.simtech-mindmapper")
-("mmf" . "application/vnd.smaf")
-("teacher" . "application/vnd.smart.teacher")
-("sdkm" . "application/vnd.solent.sdkm+xml")
-("dxp" . "application/vnd.spotfire.dxp")
-("sfs" . "application/vnd.spotfire.sfs")
-("sdc" . "application/vnd.stardivision.calc")
-("sda" . "application/vnd.stardivision.draw")
-("sdd" . "application/vnd.stardivision.impress")
-("smf" . "application/vnd.stardivision.math")
-("sdw" . "application/vnd.stardivision.writer")
-("sgl" . "application/vnd.stardivision.writer-global")
-("smzip" . "application/vnd.stepmania.package")
-("sm" . "application/vnd.stepmania.stepchart")
-("sxc" . "application/vnd.sun.xml.calc")
-("stc" . "application/vnd.sun.xml.calc.template")
-("sxd" . "application/vnd.sun.xml.draw")
-("std" . "application/vnd.sun.xml.draw.template")
-("sxi" . "application/vnd.sun.xml.impress")
-("sti" . "application/vnd.sun.xml.impress.template")
-("sxm" . "application/vnd.sun.xml.math")
-("sxw" . "application/vnd.sun.xml.writer")
-("sxg" . "application/vnd.sun.xml.writer.global")
-("stw" . "application/vnd.sun.xml.writer.template")
-("sus" . "application/vnd.sus-calendar")
-("svd" . "application/vnd.svd")
-("sis" . "application/vnd.symbian.install")
-("xsm" . "application/vnd.syncml+xml")
-("bdm" . "application/vnd.syncml.dm+wbxml")
-("xdm" . "application/vnd.syncml.dm+xml")
-("tao" . "application/vnd.tao.intent-module-archive")
-("pcap" . "application/vnd.tcpdump.pcap")
-("tmo" . "application/vnd.tmobile-livetv")
-("tpt" . "application/vnd.trid.tpt")
-("mxs" . "application/vnd.triscape.mxs")
-("tra" . "application/vnd.trueapp")
-("ufd" . "application/vnd.ufdl")
-("utz" . "application/vnd.uiq.theme")
-("umj" . "application/vnd.umajin")
-("unityweb" . "application/vnd.unity")
-("uoml" . "application/vnd.uoml+xml")
-("vcx" . "application/vnd.vcx")
-("vsd" . "application/vnd.visio")
-("vis" . "application/vnd.visionary")
-("vsf" . "application/vnd.vsf")
-("wbxml" . "application/vnd.wap.wbxml")
-("wmlc" . "application/vnd.wap.wmlc")
-("wmlsc" . "application/vnd.wap.wmlscriptc")
-("wtb" . "application/vnd.webturbo")
-("nbp" . "application/vnd.wolfram.player")
-("wpd" . "application/vnd.wordperfect")
-("wqd" . "application/vnd.wqd")
-("stf" . "application/vnd.wt.stf")
-("xar" . "application/vnd.xara")
-("xfdl" . "application/vnd.xfdl")
-("hvd" . "application/vnd.yamaha.hv-dic")
-("hvs" . "application/vnd.yamaha.hv-script")
-("hvp" . "application/vnd.yamaha.hv-voice")
-("osf" . "application/vnd.yamaha.openscoreformat")
-("osfpvg" . "application/vnd.yamaha.openscoreformat.osfpvg+xml")
-("saf" . "application/vnd.yamaha.smaf-audio")
-("spf" . "application/vnd.yamaha.smaf-phrase")
-("cmp" . "application/vnd.yellowriver-custom-menu")
-("zir" . "application/vnd.zul")
-("zaz" . "application/vnd.zzazz.deck+xml")
-("vxml" . "application/voicexml+xml")
-("wgt" . "application/widget")
-("hlp" . "application/winhlp")
-("wsdl" . "application/wsdl+xml")
-("wspolicy" . "application/wspolicy+xml")
-("7z" . "application/x-7z-compressed")
-("abw" . "application/x-abiword")
-("ace" . "application/x-ace-compressed")
-("dmg" . "application/x-apple-diskimage")
-("aab" . "application/x-authorware-bin")
-("aam" . "application/x-authorware-map")
-("aas" . "application/x-authorware-seg")
-("bcpio" . "application/x-bcpio")
-("torrent" . "application/x-bittorrent")
-("blb" . "application/x-blorb")
-("bz" . "application/x-bzip")
-("bz2" . "application/x-bzip2")
-("cbr" . "application/x-cbr")
-("vcd" . "application/x-cdlink")
-("cfs" . "application/x-cfs-compressed")
-("chat" . "application/x-chat")
-("pgn" . "application/x-chess-pgn")
-("nsc" . "application/x-conference")
-("cpio" . "application/x-cpio")
-("csh" . "application/x-csh")
-("deb" . "application/x-debian-package")
-("dgc" . "application/x-dgc-compressed")
-("dir" . "application/x-director")
-("wad" . "application/x-doom")
-("ncx" . "application/x-dtbncx+xml")
-("dtb" . "application/x-dtbook+xml")
-("res" . "application/x-dtbresource+xml")
-("dvi" . "application/x-dvi")
-("evy" . "application/x-envoy")
-("eva" . "application/x-eva")
-("bdf" . "application/x-font-bdf")
-("gsf" . "application/x-font-ghostscript")
-("psf" . "application/x-font-linux-psf")
-("otf" . "application/x-font-otf")
-("pcf" . "application/x-font-pcf")
-("snf" . "application/x-font-snf")
-("ttf" . "application/x-font-ttf")
-("pfa" . "application/x-font-type1")
-("woff" . "application/x-font-woff")
-("arc" . "application/x-freearc")
-("spl" . "application/x-futuresplash")
-("gca" . "application/x-gca-compressed")
-("ulx" . "application/x-glulx")
-("gnumeric" . "application/x-gnumeric")
-("gramps" . "application/x-gramps-xml")
-("gtar" . "application/x-gtar")
-("hdf" . "application/x-hdf")
-("install" . "application/x-install-instructions")
-("iso" . "application/x-iso9660-image")
-("jnlp" . "application/x-java-jnlp-file")
-("latex" . "application/x-latex")
-("lzh" . "application/x-lzh-compressed")
-("mie" . "application/x-mie")
-("prc" . "application/x-mobipocket-ebook")
-("m3u8" . "application/x-mpegurl")
-("application" . "application/x-ms-application")
-("lnk" . "application/x-ms-shortcut")
-("wmd" . "application/x-ms-wmd")
-("wmz" . "application/x-ms-wmz")
-("xbap" . "application/x-ms-xbap")
-("mdb" . "application/x-msaccess")
-("obd" . "application/x-msbinder")
-("crd" . "application/x-mscardfile")
-("clp" . "application/x-msclip")
-("exe" . "application/x-msdownload")
-("mvb" . "application/x-msmediaview")
-("wmf" . "application/x-msmetafile")
-("mny" . "application/x-msmoney")
-("pub" . "application/x-mspublisher")
-("scd" . "application/x-msschedule")
-("trm" . "application/x-msterminal")
-("wri" . "application/x-mswrite")
-("nc" . "application/x-netcdf")
-("nzb" . "application/x-nzb")
-("p12" . "application/x-pkcs12")
-("p7b" . "application/x-pkcs7-certificates")
-("p7r" . "application/x-pkcs7-certreqresp")
-("rar" . "application/x-rar-compressed")
-("ris" . "application/x-research-info-systems")
-("sh" . "application/x-sh")
-("shar" . "application/x-shar")
-("swf" . "application/x-shockwave-flash")
-("xap" . "application/x-silverlight-app")
-("sql" . "application/x-sql")
-("sit" . "application/x-stuffit")
-("sitx" . "application/x-stuffitx")
-("srt" . "application/x-subrip")
-("sv4cpio" . "application/x-sv4cpio")
-("sv4crc" . "application/x-sv4crc")
-("t3" . "application/x-t3vm-image")
-("gam" . "application/x-tads")
-("tar" . "application/x-tar")
-("tcl" . "application/x-tcl")
-("tex" . "application/x-tex")
-("tfm" . "application/x-tex-tfm")
-("texinfo" . "application/x-texinfo")
-("obj" . "application/x-tgif")
-("ustar" . "application/x-ustar")
-("src" . "application/x-wais-source")
-("der" . "application/x-x509-ca-cert")
-("fig" . "application/x-xfig")
-("xlf" . "application/x-xliff+xml")
-("xpi" . "application/x-xpinstall")
-("xz" . "application/x-xz")
-("z1" . "application/x-zmachine")
-("xaml" . "application/xaml+xml")
-("xdf" . "application/xcap-diff+xml")
-("xenc" . "application/xenc+xml")
-("xhtml" . "application/xhtml+xml")
-("xml" . "application/xml")
-("dtd" . "application/xml-dtd")
-("xop" . "application/xop+xml")
-("xpl" . "application/xproc+xml")
-("xslt" . "application/xslt+xml")
-("xspf" . "application/xspf+xml")
-("mxml" . "application/xv+xml")
-("yang" . "application/yang")
-("yin" . "application/yin+xml")
-("zip" . "application/zip")
-("adp" . "audio/adpcm")
-("au" . "audio/basic")
-("mid" . "audio/midi")
-("mp4a" . "audio/mp4")
-("m4a" . "audio/mp4a-latm")
-("mpga" . "audio/mpeg")
-("oga" . "audio/ogg")
-("s3m" . "audio/s3m")
-("sil" . "audio/silk")
-("uva" . "audio/vnd.dece.audio")
-("eol" . "audio/vnd.digital-winds")
-("dra" . "audio/vnd.dra")
-("dts" . "audio/vnd.dts")
-("dtshd" . "audio/vnd.dts.hd")
-("lvp" . "audio/vnd.lucent.voice")
-("pya" . "audio/vnd.ms-playready.media.pya")
-("ecelp4800" . "audio/vnd.nuera.ecelp4800")
-("ecelp7470" . "audio/vnd.nuera.ecelp7470")
-("ecelp9600" . "audio/vnd.nuera.ecelp9600")
-("rip" . "audio/vnd.rip")
-("weba" . "audio/webm")
-("aac" . "audio/x-aac")
-("aif" . "audio/x-aiff")
-("caf" . "audio/x-caf")
-("flac" . "audio/x-flac")
-("mka" . "audio/x-matroska")
-("m3u" . "audio/x-mpegurl")
-("wax" . "audio/x-ms-wax")
-("wma" . "audio/x-ms-wma")
-("ram" . "audio/x-pn-realaudio")
-("rmp" . "audio/x-pn-realaudio-plugin")
-("wav" . "audio/x-wav")
-("xm" . "audio/xm")
-("cdx" . "chemical/x-cdx")
-("cif" . "chemical/x-cif")
-("cmdf" . "chemical/x-cmdf")
-("cml" . "chemical/x-cml")
-("csml" . "chemical/x-csml")
-("xyz" . "chemical/x-xyz")
-("bmp" . "image/bmp")
-("cgm" . "image/cgm")
-("g3" . "image/g3fax")
-("gif" . "image/gif")
-("ief" . "image/ief")
-("jp2" . "image/jp2")
-("jpeg" . "image/jpeg")
-("ktx" . "image/ktx")
-("pict" . "image/pict")
-("png" . "image/png")
-("btif" . "image/prs.btif")
-("sgi" . "image/sgi")
-("svg" . "image/svg+xml")
-("tiff" . "image/tiff")
-("psd" . "image/vnd.adobe.photoshop")
-("uvi" . "image/vnd.dece.graphic")
-("sub" . "image/vnd.dvb.subtitle")
-("djvu" . "image/vnd.djvu")
-("dwg" . "image/vnd.dwg")
-("dxf" . "image/vnd.dxf")
-("fbs" . "image/vnd.fastbidsheet")
-("fpx" . "image/vnd.fpx")
-("fst" . "image/vnd.fst")
-("mmr" . "image/vnd.fujixerox.edmics-mmr")
-("rlc" . "image/vnd.fujixerox.edmics-rlc")
-("mdi" . "image/vnd.ms-modi")
-("wdp" . "image/vnd.ms-photo")
-("npx" . "image/vnd.net-fpx")
-("wbmp" . "image/vnd.wap.wbmp")
-("xif" . "image/vnd.xiff")
-("webp" . "image/webp")
-("3ds" . "image/x-3ds")
-("ras" . "image/x-cmu-raster")
-("cmx" . "image/x-cmx")
-("fh" . "image/x-freehand")
-("ico" . "image/x-icon")
-("pntg" . "image/x-macpaint")
-("sid" . "image/x-mrsid-image")
-("pcx" . "image/x-pcx")
-("pic" . "image/x-pict")
-("pnm" . "image/x-portable-anymap")
-("pbm" . "image/x-portable-bitmap")
-("pgm" . "image/x-portable-graymap")
-("ppm" . "image/x-portable-pixmap")
-("qtif" . "image/x-quicktime")
-("rgb" . "image/x-rgb")
-("tga" . "image/x-tga")
-("xbm" . "image/x-xbitmap")
-("xpm" . "image/x-xpixmap")
-("xwd" . "image/x-xwindowdump")
-("eml" . "message/rfc822")
-("igs" . "model/iges")
-("msh" . "model/mesh")
-("dae" . "model/vnd.collada+xml")
-("dwf" . "model/vnd.dwf")
-("gdl" . "model/vnd.gdl")
-("gtw" . "model/vnd.gtw")
-("mts" . "model/vnd.mts")
-("vtu" . "model/vnd.vtu")
-("wrl" . "model/vrml")
-("x3db" . "model/x3d+binary")
-("x3dv" . "model/x3d+vrml")
-("x3d" . "model/x3d+xml")
-("manifest" . "text/cache-manifest")
-("appcache" . "text/cache-manifest")
-("ics" . "text/calendar")
-("css" . "text/css")
-("csv" . "text/csv")
-("html" . "text/html")
-("n3" . "text/n3")
-("txt" . "text/plain")
-("dsc" . "text/prs.lines.tag")
-("rtx" . "text/richtext")
-("sgml" . "text/sgml")
-("tsv" . "text/tab-separated-values")
-("t" . "text/troff")
-("ttl" . "text/turtle")
-("uri" . "text/uri-list")
-("vcard" . "text/vcard")
-("curl" . "text/vnd.curl")
-("dcurl" . "text/vnd.curl.dcurl")
-("scurl" . "text/vnd.curl.scurl")
-("mcurl" . "text/vnd.curl.mcurl")
-("sub" . "text/vnd.dvb.subtitle")
-("fly" . "text/vnd.fly")
-("flx" . "text/vnd.fmi.flexstor")
-("gv" . "text/vnd.graphviz")
-("3dml" . "text/vnd.in3d.3dml")
-("spot" . "text/vnd.in3d.spot")
-("jad" . "text/vnd.sun.j2me.app-descriptor")
-("wml" . "text/vnd.wap.wml")
-("wmls" . "text/vnd.wap.wmlscript")
-("s" . "text/x-asm")
-("c" . "text/x-c")
-("f" . "text/x-fortran")
-("java" . "text/x-java-source")
-("opml" . "text/x-opml")
-("p" . "text/x-pascal")
-("nfo" . "text/x-nfo")
-("etx" . "text/x-setext")
-("sfv" . "text/x-sfv")
-("uu" . "text/x-uuencode")
-("vcs" . "text/x-vcalendar")
-("vcf" . "text/x-vcard")
-("3gp" . "video/3gpp")
-("3g2" . "video/3gpp2")
-("h261" . "video/h261")
-("h263" . "video/h263")
-("h264" . "video/h264")
-("jpgv" . "video/jpeg")
-("jpm" . "video/jpm")
-("mj2" . "video/mj2")
-("ts" . "video/mp2t")
-("mp4" . "video/mp4")
-("mpeg" . "video/mpeg")
-("ogv" . "video/ogg")
-("qt" . "video/quicktime")
-("uvh" . "video/vnd.dece.hd")
-("uvm" . "video/vnd.dece.mobile")
-("uvp" . "video/vnd.dece.pd")
-("uvs" . "video/vnd.dece.sd")
-("uvv" . "video/vnd.dece.video")
-("dvb" . "video/vnd.dvb.file")
-("fvt" . "video/vnd.fvt")
-("mxu" . "video/vnd.mpegurl")
-("pyv" . "video/vnd.ms-playready.media.pyv")
-("uvu" . "video/vnd.uvvu.mp4")
-("viv" . "video/vnd.vivo")
-("dv" . "video/x-dv")
-("webm" . "video/webm")
-("f4v" . "video/x-f4v")
-("fli" . "video/x-fli")
-("flv" . "video/x-flv")
-("m4v" . "video/x-m4v")
-("mkv" . "video/x-matroska")
-("mng" . "video/x-mng")
-("asf" . "video/x-ms-asf")
-("vob" . "video/x-ms-vob")
-("wm" . "video/x-ms-wm")
-("wmv" . "video/x-ms-wmv")
-("wmx" . "video/x-ms-wmx")
-("wvx" . "video/x-ms-wvx")
-("avi" . "video/x-msvideo")
-("movie" . "video/x-sgi-movie")
-("smv" . "video/x-smv")
-("ice" . "x-conference/x-cooltalk")))
-
-(define (ext->mimetype ext)
-  (let ((x (assoc ext ducttape_ext2mimetype)))
-   (if x (cdr x) "text/plain")))

DELETED ducttape/sample_ducttape.scm
Index: ducttape/sample_ducttape.scm
==================================================================
--- ducttape/sample_ducttape.scm
+++ /dev/null
@@ -1,4 +0,0 @@
-(include "ducttape-lib.scm")
-(import ducttape-lib)
-(inote "hello world")
-(exit 0)

DELETED ducttape/test_ducttape.scm
Index: ducttape/test_ducttape.scm
==================================================================
--- ducttape/test_ducttape.scm
+++ /dev/null
@@ -1,355 +0,0 @@
-#!/usr/bin/env csi -script
-(use test)
-(include "ducttape-lib.scm")
-(import ducttape-lib)
-(import ansi-escape-sequences)
-(use trace)
-(set! systype (do-or-die (if (file-exists? "/bin/uname") "/bin/uname" "/usr/bin/uname")))
-;(trace skim-cmdline-opts-withargs-by-regex)
-;(trace keyword-skim)
-;(trace re-match?)
-(define (reset-ducttape)
-  (unsetenv "DUCTTAPE_DEBUG_LEVEL")
-  (ducttape-debug-level #f)
-
-  (unsetenv "DUCTTAPE_DEBUG_PATTERN")
-  (ducttape-debug-regex-filter ".")
-
-  (unsetenv "DUCTTAPE_LOG_FILE")
-  (ducttape-log-file #f)
-
-  (unsetenv "DUCTTAPE_SILENT_MODE")
-  (ducttape-silent-mode #f)
-
-  (unsetenv "DUCTTAPE_QUIET_MODE")
-  (ducttape-quiet-mode #f)
-
-  (unsetenv "DUCTTAPE_COLOR_MODE")
-  (ducttape-color-mode #f)
-)
-
-(define (reset-ducttape-with-cmdline-list cmdline-list)
-  (reset-ducttape)
-
-  (command-line-arguments cmdline-list)
-  (ducttape-process-command-line)
-)
-
-
-(define (direct-iputs-test)
-  (ducttape-color-mode #f)
-  (ierr "I'm an error")
-  (iwarn "I'm a warning")
-  (inote "I'm a note")
-
-  (ducttape-debug-level 1)
-  (idbg "I'm a debug statement")
-  (ducttape-debug-level #f)
-  (idbg "I'm a hidden debug statement")
-
-  (ducttape-silent-mode #t)
-  (iwarn "I shouldn't show up")
-  (inote "I shouldn't show up either")
-  (ierr "I should show up 1")
-  (ducttape-silent-mode #f)
-
-  (ducttape-quiet-mode #t)
-  (iwarn "I should show up 2")
-  (inote "I shouldn't show up though")
-  (ierr "I should show up 3")
-  (ducttape-quiet-mode #f)
-
-  (ducttape-debug-level 1)
-  (idbg "foo")
-  (iputs "dbg" "debug message")
-  (iputs "e" "error message")
-  (iputs "w" "warning message")
-  (iputs "n" "note message")
-
-  (ducttape-color-mode #t)
-  (ierr "I'm an error COLOR")
-  (iwarn "I'm a warning COLOR")
-  (inote "I'm a note COLOR")
-  (idbg "I'm a debug COLOR")
-
-
-  )
-
-(define (test-argprocessor-funcs)
-  
-  (test-group
-   "Command line processor utility functions"
-
-   (set! testargs1 '( "-d" "-d" "-d3" "-ddd" "-foo" "fooarg" "-foo" "fooarg2" "-lastArgIsDecoy" "-foo"))
-   (command-line-arguments testargs1)
-   (set! expected_result '("-d" "-d" "-d3" "-ddd"))
-   (set! expected_sideeffect '("-foo" "fooarg" "-foo" "fooarg2" "-lastArgIsDecoy" "-foo"))
-
-   (test "skim-cmdline-opts-noarg-by-regex result" expected_result (skim-cmdline-opts-noarg-by-regex "-d(d+|\\d+)?"))
-   (test "skim-cmdline-opts-noarg-by-regex sideeffect" expected_sideeffect (command-line-arguments))
-
-
-  
-   (command-line-arguments testargs1)
-   (set! expected_result '("fooarg" "fooarg2" ))
-   (set! expected_sideeffect '( "-d" "-d" "-d3" "-ddd" "-lastArgIsDecoy" "-foo"))
-   (test
-    "skim-cmdline-opts-withargs-by-regex result"
-    expected_result
-    (skim-cmdline-opts-withargs-by-regex "--?foo"))
-   
-   (test
-    "skim-cmdline-opts-withargs-by-regex sideeffect"
-    expected_sideeffect
-    (command-line-arguments))
-
-   ))
-
-(define (test-misc)
-  (test-group
-   "misc"
-   (let ((tmpfile (mktemp)))
-     (test-assert "mktemp: temp file created" (file-exists? tmpfile))
-     (if (file-exists? tmpfile)
-         (delete-file tmpfile))
-
-     )))
-
-
-
-(define (test-systemstuff)
-  (test-group
-   "system commands"
-
-   (let-values (((ec o e) (isys (find-exe "true"))))
-     (test-assert "isys: /bin/true should have exit code 0" (equal? ec 0)))
-   (let-values (((ec o e) (isys (find-exe "false"))))
-     (test-assert "isys: /bin/false should have exit code 1" (equal? ec 1)))
-
-   (let-values (((ec o e) (isys "/bin/echo" "foo" "bar" "baz")))
-     (test-assert "isys: /bin/echo should have exit code 0" (equal? ec 0))
-     (test-assert "isys: /bin/echo should have stdout 'foo bar baz'" (equal? o "foo bar baz")))
-   
-   (let-values (((ec o e) (isys "/bin/ls /zzzzz")))
-     (let ((expected-code
-            (if (equal? systype "Darwin") 1 2))
-           (expected-err
-            (if (equal? systype "Darwin")
-                "ls: /zzzzz: No such file or directory"
-                "/bin/ls: cannot access /zzzzz: No such file or directory"))
-
-           )
-       (test "isys: /bin/ls /zzzzz should have exit code 2" expected-code ec)
-       (test "isys: /bin/ls /zzzzz should have empty stdout" "" o)
-       (test
-        "isys: /bin/ls /zzzzz should have stderr"
-        expected-err
-        e))
-     )
-
-   (let-values (((ec o e) (isys "/bin/ls /etc/passwd")))
-     (test "isys: /bin/ls /etc/passwd should have exit code 0" 0 ec)
-     (test "isys: /bin/ls /etc/passwd should have stdout" "/etc/passwd" o)
-     (test
-      "isys: /bin/ls /etc/passwd should have empty stderr"
-      ""
-      e))
-
-      (let ((res (do-or-die "/bin/ls /etc/passwd")))
-        (test
-         "do-or-die: ls /etc/passwd should work"
-         "/etc/passwd" res ))
-
-      (let ((res (do-or-die "/bin/ls /zzzzz" nodie: #t)))
-        (test
-         "do-or-die: ls /zzzzz should die"
-         #f res ))
-
-      ; test reading from process stdout line at a time
-      (let* (
-             (lineno (counter-maker))
-
-             ; print each line with an index
-             (eachline-fn (lambda (line)
-                         (print "GOTLINE " (lineno) "> " line)))
-
-             (res
-              (do-or-die "/bin/ls -l /etc | head; true"
-                         foreach-stdout: eachline-fn )))
-        
-        (test-assert "ls -l /etc should not be empty"
-                     (not (equal? res ""))))
-      ;; test writing to process stdout line at a time
-
-      (let* ((tmpfile (mktemp))
-             (cmd (conc "cat > " tmpfile)))
-        (let-values (((c o e)
-                      (isys cmd stdin-proc:
-                       (lambda (myport)
-                         (write-line "hello" myport)
-                         (write-line "hello2" myport)
-                         (close-output-port myport)))))
-          (test "isys-sp: cat should exit 0" 0 c)
-          (let ((mycmd (conc "cat " tmpfile)))
-            (test "isys-sp: cat output should match input" "hello\nhello2" (do-or-die mycmd)))
-
-          (delete-file tmpfile)
-        ))
-
-      (let* ((tmpfile (mktemp))
-             (cmd (conc "cat > " tmpfile)))
-        (do-or-die cmd stdin-proc:
-                   (lambda (myport)
-                     (write-line "hello" myport)
-                     (write-line "hello2" myport)
-                     (close-output-port myport))
-                   cmd)
-        (test "dod-sp: cat output should match input" "hello\nhello2" (do-or-die (conc "cat " tmpfile)))
-        (delete-file tmpfile))
-
-
-
-      
-
-      (let*
-          ((thefile (conc "/tmp/" (get-environment-variable "USER")  "9-lines"))
-           (counter (counter-maker))
-           (stdin-writer
-            (lambda ()
-              (if (< (counter) 10)
-                  (number->string (counter 0))
-                  #f)))
-            (cmd (conc "cat > " thefile)))
-        (let-values
-            (((c o e)
-              (isys cmd foreach-stdin-thunk: stdin-writer)))
-
-          (test-assert "isys-fsl: cat should return 0" (equal? c 0))
-
-          (test-assert
-           "isys-fsl: cat should have written a file"
-           (file-exists? thefile))
-          
-          (if
-           (file-exists? thefile)
-           (begin
-             (test "isys-fsl: cat file should have right contents" "1\n2\n3\n4\n5\n6\n7\n8\n9" (do-or-die (conc "cat " thefile)))
-             (delete-file thefile)))))
-      
-   ) ; end test-group
-  ) ; end define
-
-   
-(define (test-argprocessor )
-  (test-group
-   "Command line processor parameter settings"
-
-   (reset-ducttape-with-cmdline-list '())
-   (test-assert "(nil) debug mode should be off" (not (ducttape-debug-level)))
-   (test-assert "(nil): debug pattern should be '.'" (equal? "." (ducttape-debug-regex-filter)))
-   (test-assert "(nil): colors should be off" (not (ducttape-color-mode)))
-   (test-assert "(nil): silent mode should be off" (not (ducttape-silent-mode)))
-   (test-assert "(nil): quiet mode should be off" (not (ducttape-quiet-mode)))
-   (test-assert "(nil): logfile should be off" (not (ducttape-log-file)))
-
-   (reset-ducttape-with-cmdline-list '("-d"))
-   (test-assert "-d: debug mode should be on at level 1" (eq? 1 (ducttape-debug-level)))
-
-   (reset-ducttape-with-cmdline-list '("-dd"))
-   (test "-dd: debug level should be 2" 2 (ducttape-debug-level))
-
-   (reset-ducttape-with-cmdline-list '("-ddd"))
-   (test "-ddd: debug level should be 3" 3 (ducttape-debug-level))
-
-   (reset-ducttape-with-cmdline-list '("-d2"))
-   (test "-d2: debug level should be 2" 2 (ducttape-debug-level))
-
-   (reset-ducttape-with-cmdline-list '("-d3"))
-   (test "-d3: debug level should be 3" 3 (ducttape-debug-level))
-
-   (reset-ducttape-with-cmdline-list '("-dp" "foo"))
-   (test "-dp foo: debug pattern should be 'foo'" "foo" (ducttape-debug-regex-filter))
-
-   (reset-ducttape-with-cmdline-list '("--debug-pattern" "foo"))
-   (test "--debug-pattern foo: debug pattern should be 'foo'" "foo" (ducttape-debug-regex-filter))
-
-   (reset-ducttape-with-cmdline-list '("-dp" "foo" "-dp" "bar"))
-   (test "-dp foo -dp bar: debug pattern should be 'foo|bar'"  "foo|bar" (ducttape-debug-regex-filter))
-
-   (reset-ducttape-with-cmdline-list '("--quiet"))
-   (test-assert "-quiet: quiet mode should be active" (ducttape-quiet-mode))
-
-   (reset-ducttape-with-cmdline-list '("--silent"))
-   (test-assert "-silent: silent mode should be active" (ducttape-silent-mode))
-
-   (reset-ducttape-with-cmdline-list '("--color"))
-   (test-assert "-color: color mode should be active" (ducttape-color-mode))
-
-   (reset-ducttape-with-cmdline-list '("--log" "foo"))
-   (test "--log foo: logfile should be 'foo'" "foo" (ducttape-log-file))
-
-))
-
-(define (test-wwdate)
-  (test-group
-   "wwdate conversion tests"
-   (let ((test-table
-          '(("16ww01.5" . "2016-01-01")
-            ("16ww18.5" . "2016-04-29")
-            ("1999ww33.5" . "1999-08-13")
-            ("16ww18.4" . "2016-04-28")
-            ("16ww18.3" . "2016-04-27")
-            ("13ww01.0" . "2012-12-30")
-            ("13ww52.6" . "2013-12-28")
-            ("16ww53.3" . "2016-12-28"))))
-     (for-each
-      (lambda (test-pair)
-        (let ((wwdate (car test-pair))
-              (isodate (cdr test-pair)))
-          (test
-           (conc "(isodate->wwdate "isodate ") => "wwdate)
-           wwdate
-           (isodate->wwdate isodate))
-          
-          (test
-           (conc "(wwdate->isodate "wwdate ")   => "isodate)
-           isodate
-           (wwdate->isodate wwdate))))
-      test-table))))
-
-(define (main)
-  ;; (test   )
-  
-;  (test-group "silly settext group"
-;              (test #f "\x1b[1mfoo\x1b[0m" (set-text (list 'bold) "foo"))
-;              (test "settext bold" "\x1b[1mfoo\x1b[0m" (set-text (list 'bold) "foo"))
-;              )
-
-  ; visually inspect this
-  (direct-iputs-test)
-
-  ; following use unit test test-egg
-  (reset-ducttape)
-  (test-argprocessor-funcs)
-  (reset-ducttape)
-  (test-argprocessor)
-  (test-systemstuff)
-  (test-misc)
-  (test-wwdate)
-  ) ; end main()
-
-(main)
-(sendmail "brandon.j.barclay@intel.com" "6hello subject"  "test body" )
-
-;(let* ((image-file "/nfs/site/home/bjbarcla/megatest-logo.png")
-;       (cid "mtlogo")
-;       (image-alist (list (cons image-file cid)))
-;       (body  (conc "Hello world
\"test
bye!")))
-
-;  (sendmail "brandon.j.barclay@intel.com" "7hello subject"  body use_html: #t images-with-content-id-alist: image-alist)
-;  (print "sent image mail"))
-;(sendmail "bjbarcla" "2hello subject html"  "test body
hello
italics" use_html: #t)
-;(sendmail "bb" "4hello attach subject html"  "
hmm
" use_html: #t attach-files-list: '( "/Users/bb/Downloads/wdmycloud-manual-4779-705103.pdf" ) )
-
-;(launch-repl)
-(test-exit)

DELETED ducttape/test_example.scm
Index: ducttape/test_example.scm
==================================================================
--- ducttape/test_example.scm
+++ /dev/null
@@ -1,3 +0,0 @@
-(use ducttape-lib)
-
-(inote "Hello world")

DELETED ducttape/useargs-example.scm
Index: ducttape/useargs-example.scm
==================================================================
--- ducttape/useargs-example.scm
+++ /dev/null
@@ -1,19 +0,0 @@
-(use ducttape-lib)
-
-(let (
-      (customers (skim-cmdline-opts-withargs-by-regex "--cust(omer)?"))
-      (magicmode (skim-cmdline-opts-noarg-by-regex "--magic"))
-      )
-  (print "your customers are " customers)
-  (if (null? magicmode)
-      (print "no unicorns for you")
-      (print "magic!")
-  )
-  )
-
-(idbg "hello")
-(idbg "hello2" 2)
-(idbg "hello2" 3)
-(inote "note")
-(iwarn "warn")
-(ierr "err")

DELETED ducttape/workweekdate.scm
Index: ducttape/workweekdate.scm
==================================================================
--- ducttape/workweekdate.scm
+++ /dev/null
@@ -1,193 +0,0 @@
-(use srfi-19)
-(use test)
-;;(use format)
-(use regex)
-;(declare (unit wwdate))
-;; utility procedures to convert among
-;; different ways to express date (wwdate, seconds since epoch, isodate)
-;;
-;; samples:
-;; isodate   -> "2016-01-01"
-;; wwdate -> "16ww01.5"
-;; seconds   -> 1451631600
-
-;; procedures provided:
-;; ====================
-;; seconds->isodate
-;; seconds->wwdate
-;;
-;; isodate->seconds
-;; isodate->wwdate
-;;
-;; wwdate->seconds
-;; wwdate->isodate
-
-;; srfi-19 used extensively; this doc is better tha the eggref:
-;; http://srfi.schemers.org/srfi-19/srfi-19.html
-
-;; Author: brandon.j.barclay@intel.com 16ww18.6
-
-(define (date->seconds date)
-  (inexact->exact
-   (string->number
-    (date->string date "~s"))))
-
-(define (seconds->isodate seconds)
-  (let* ((date (seconds->date seconds))
-         (result (date->string date "~Y-~m-~d")))
-    result))
-
-(define (isodate->seconds isodate)
-  "Takes a string input of the form 'YY-MM-DD' or 'YYYY-MM-DD' and returns epoch time; for YY, assume after Y2K"
-  (let* ((numlist (map string->number (string-split isodate "-")))
-        (raw-year (car numlist))
-        (year (if (< raw-year 100) (+ raw-year 2000) raw-year))
-        (month (list-ref numlist 1))
-        (day (list-ref numlist 2))
-        (date (make-date 0 0 0 0 day month year))
-        (seconds (date->seconds date)))
-
-    seconds))
-
-;; adapted from perl Intel::WorkWeek perl module
-;; workweek year consists of numbered weeks starting from week 1
-;;   days of week are numbered starting from 0 on sunday
-;;   weeks begin on sunday- day number 0 and end saturday- day 6
-;;   week 1 is defined as the week containing jan 1 of the year
-;;   workweek year does not match calendar year in workweek 1
-;;     since workweek 1 contains jan1 and workweek begins sunday,
-;;     days prior to jan1 in workweek 1 belong to the next workweek year
-(define (seconds->wwdate-values seconds)
-  (define (date-difference->seconds d1 d2)
-    (- (date->seconds d1) (date->seconds d2)))
-
-  (let* ((thisdate (seconds->date seconds))
-         (thisdow (string->number (date->string thisdate "~w")))
-
-         (year (date-year thisdate))
-         ;; intel workweek 1 begins on sunday of week containing jan1
-         (jan1 (make-date 0 0 0 0 1 1 year))
-         (jan1dow (date-week-day jan1))
-         (ww01 (date-subtract-duration jan1 (seconds->time (* 60 60 24 jan1dow))))
-
-         (ww01_delta_seconds (date-difference->seconds thisdate ww01))
-         (wwnum_initial (inexact->exact (add1 (floor (/ ww01_delta_seconds 24 3600 7) ))))
-         
-         ;; we could be in ww1 of next year
-         (this-saturday (seconds->date
-                         (+ seconds
-                            (* 60 60 24 (- 6 thisdow)))))
-         (this-week-ends-next-year?
-          (> (date-year this-saturday) year))
-         (intelyear
-          (if this-week-ends-next-year?
-              (add1 year)
-              year))
-         (intelweek
-          (if this-week-ends-next-year?
-              1
-              wwnum_initial)))
-   (values intelyear intelweek thisdow)))
-
-(define (string-leftpad in width pad-char)
-  (let* ((unpadded-str (->string in))
-         (padlen_temp (- width (string-length unpadded-str)))
-         (padlen (if (< padlen_temp 0) 0 padlen_temp))
-         (padding (make-string padlen pad-char)))
-    (conc padding unpadded-str)))
-
-(define (string-rightpad in width pad-char)
-  (let* ((unpadded-str (->string in))
-         (padlen_temp (- width (string-length unpadded-str)))
-         (padlen (if (< padlen_temp 0) 0 padlen_temp))
-         (padding (make-string padlen pad-char)))
-    (conc unpadded-str padding)))
-
-(define (zeropad num width)
-  (string-leftpad num width #\0))
-
-(define (seconds->wwdate seconds)
-
-  (let-values (((intelyear intelweek day-of-week-num)
-                (seconds->wwdate-values seconds)))
-    (let ((intelyear-str
-           (zeropad
-            (->string
-             (if (> intelyear 1999)
-                 (- intelyear 2000) intelyear))
-            2))
-          (intelweek-str
-           (zeropad (->string intelweek) 2))
-          (dow-str (->string day-of-week-num)))
-      (conc intelyear-str "ww" intelweek-str "." dow-str))))
-
-(define (isodate->wwdate isodate)
-  (seconds->wwdate
-   (isodate->seconds isodate)))
-
-(define (wwdate->seconds wwdate)
-  (let ((match (string-match "^(\\d+)ww(\\d+).(\\d)$" wwdate)))
-    (if
-     (not match)
-     #f
-     (let* (
-            (intelyear-raw (string->number (list-ref match 1)))
-            (intelyear (if (< intelyear-raw 100)
-                           (+ intelyear-raw 2000)
-                           intelyear-raw))
-            (intelww (string->number (list-ref match 2)))
-            (dayofweek (string->number (list-ref match 3)))
-
-            (day-of-seconds (* 60 60 24 ))
-            (week-of-seconds (* day-of-seconds 7))
-            
-
-            ;; get seconds at ww1.0
-            (new-years-date (make-date 0 0 0 0 1 1 intelyear))
-            (new-years-seconds
-             (date->seconds new-years-date))
-            (new-years-dayofweek (date-week-day new-years-date))
-            (ww1.0_seconds (- new-years-seconds
-                              (* day-of-seconds
-                                 new-years-dayofweek)))
-            (workweek-adjustment (* week-of-seconds (sub1 intelww)))
-            (weekday-adjustment (* dayofweek day-of-seconds))
-
-            (result (+ ww1.0_seconds workweek-adjustment weekday-adjustment)))
-       result))))
-
-(define (wwdate->isodate wwdate)
-  (seconds->isodate (wwdate->seconds wwdate)))
-
-(define (current-wwdate)
-  (seconds->wwdate (current-seconds)))
-
-(define (current-isodate)
-  (seconds->isodate (current-seconds)))
-
-(define (wwdate-tests)
-  (test-group
-   "date conversion tests"
-   (let ((test-table
-          '(("16ww01.5" . "2016-01-01")
-            ("16ww18.5" . "2016-04-29")
-            ("1999ww33.5" . "1999-08-13")
-            ("16ww18.4" . "2016-04-28")
-            ("16ww18.3" . "2016-04-27")
-            ("13ww01.0" . "2012-12-30")
-            ("13ww52.6" . "2013-12-28")
-            ("16ww53.3" . "2016-12-28"))))
-     (for-each
-      (lambda (test-pair)
-        (let ((wwdate (car test-pair))
-              (isodate (cdr test-pair)))
-          (test
-           (conc "(isodate->wwdate "isodate ") => "wwdate)
-           wwdate
-           (isodate->wwdate isodate))
-          
-          (test
-           (conc "(wwdate->isodate "wwdate ")   => "isodate)
-           isodate
-           (wwdate->isodate wwdate))))
-      test-table))))

Index: env.scm
==================================================================
--- env.scm
+++ env.scm
@@ -12,11 +12,11 @@
 (declare (unit env))
 
 (use sql-de-lite) ;; srfi-1 posix regex regex-case srfi-69 srfi-18 call-with-environment-variables)
 
 (define (env:open-db fname)
-  (let* ((db-exists (file-exists? fname))
+  (let* ((db-exists (common:file-exists? fname))
 	 (db        (open-database fname)))
     (if (not db-exists)
 	(begin
 	  (exec (sql db "CREATE TABLE envvars (
                     id INTEGER PRIMARY KEY,

ADDED   example/q/threaded-queue.scm
Index: example/q/threaded-queue.scm
==================================================================
--- /dev/null
+++ example/q/threaded-queue.scm
@@ -0,0 +1,353 @@
+#!/opt/chicken/bin/csi -s
+
+(use mailbox-threads typed-records matchable mailbox posix)
+
+;;; create a threaded job queue
+;;; submit job
+;;;   - command line
+;;;   - working dir / default pwd
+;;;   - env hash    / default current env
+;;;   - callback on exit 0 / default noop
+;;;   - callback on nonzero exit / default noop
+;; tjq == threaded job queue; a job is a unix command
+(define getenv get-environment-variable)
+(defstruct tjq:job
+    id  ;; assigned at construction time when added to waiting q
+  state ;; assigned at construction time when added to waiting q
+  (pid #f) ;; assigned when moved from ready q to running q
+  (threadobj #f)
+  (normal-exit #f)
+  (exit-code #f) ;; assigned when moved from running to done
+  (time-entered-waiting #f)
+  (time-entered-ready   #f)
+  (time-entered-running #f)
+  (time-entered-done    #f)
+  ;; following are key options to submit method
+  (work-dir     (getenv "PWD")) ;; where to execute job
+  (setenvs     '())            ;; alist of envvars to set when running job
+  (cmdline     "/bin/true")    ;; job command line; if string, run in subshell, if list, exec.
+  (success-cb  (lambda () #t)) ;; fires when exitcode is 0
+  (fail-cb     (lambda () #t)));; fires when exitcode is not 0
+
+ 
+             
+
+(define (tjq:exception e)
+  (print "Exception: "e)
+  ;;(print-call-chain)
+  (exit 1))
+
+(define (tjq:job-thread job-id job dispatch-thread timeout-seconds)
+  ;;(print "job-thread setup for jobid "job-id)
+  (letrec
+      ((this-thread
+        (make-thread
+         (lambda ()
+           (tjq:job-threadobj-set! job this-thread)
+           ;;(print "job-thread started for jobid "job-id)
+           (let loop ((pid #f))
+             ;;(print "job-thr("job-id")> loop top.")
+             (match (thread-receive timeout-seconds 'timeout)
+               ('timeout
+                ;;(print "job-thr("job-id")> timeout; pid="pid" before cond1")
+                (cond
+                 ((number? pid) ;; check if still running
+                  ;;(print "job-thr("job-id")> timeout; pid="pid" cond1 pid-is-number branch")
+                  (let-values (((pid-or-zero normal-exit exitcode-or-signal)
+                                (process-wait pid #t)))
+
+
+                    ;; can get for large number of parallel threads (~ >= 42)
+                    ;;                     Warning (#): in thread: (process-wait) waiting for child process failed - No child processes: 11322
+                    
+                    ;; 	Call history:
+                    
+                    ;; 	threaded-queue.scm:56: ##sys#call-with-values	  
+                    ;; 	threaded-queue.scm:57: process-wait	  	<--
+                    
+                    ;; Warning (#): in thread: (process-wait) waiting for child process failed - No child processes: 11323did job 467
+                    ;; did job 464
+                    
+                    ;; Warning (#): in thread: (process-wait) waiting for child process failed - No child processes: 11318
+                    
+                    ;; 	Call history:
+                    
+                    ;; 	threaded-queue.scm:56: ##sys#call-with-values	  
+                    ;; 	threaded-queue.scm:57: process-wait	  	<--
+                    
+
+                    ;;(print "job-thr("job-id")> pid-or-zero="pid-or-zero)
+                    (cond
+                     ((zero? pid-or-zero)
+                      ;;(print "job-thr("job-id")> timeout; pid="pid" cond2 pid-or-zero is zero branch")
+                      ;;(print "job-thr("job-id")> zero; loop.")
+                      (loop pid))
+                     (else
+                      ;;(print "job-thr("job-id")> timeout; pid="pid" cond2 else branch")
+                      (tjq:job-normal-exit-set! job
+                                                (if normal-exit 'normal 'signal))
+                      (tjq:job-exit-code-set! job exitcode-or-signal)
+                      
+                      (thread-send dispatch-thread (list 'job-now-done job-id))))
+                    ;;(print "job-thr("job-id")> after cond2")
+                    ))
+                 (else
+                  ;;(print "job-thr("job-id")> timeout; pid="pid" cond1 else branch")
+                  ;;(print "job-thr("job-id")> no action; loop")
+                  (thread-sleep! timeout-seconds)
+                  (loop pid))))
+               ('run
+                ;;(print "job-thr("job-id")> run called")
+                (let* ((cmdline (tjq:job-cmdline job))
+                       (newpid (if (list? cmdline)
+                                (process-run (car cmdline) (cdr cmdline))
+                                (process-run cmdline))))
+                  (tjq:job-pid-set! job newpid)
+                  (thread-send dispatch-thread
+                               (list 'job-now-running job-id))
+                  (loop newpid)))
+               (e
+                (print "tjq:job-thread("job-id") illegal message received:")
+                (pp e)
+               (exit 1))))
+           ;;(print "job-thread finished for jobid "job-id)
+           #f))))
+    this-thread))
+       
+       
+(define (tjq:dispatcher-thread qname job-hash sync-job-cap obj #!key
+                               (job-thread-timeout-seconds 0.1)
+                               (timeout-seconds 0.1)
+                               )
+  (letrec
+   (;; options to configure behavior of dispatcher
+    (stop #f)
+    ;;(timeout-seconds 0.5)
+    ;;(job-thread-timeout-seconds 0.5)
+    ;; define long-running thread which receives requests and coordinates
+    ;; job execution
+    (this-thread
+     (make-thread
+      (lambda ()
+        (let loop ((next-job-id 0)
+                   ;; four job queues holding job mbox-type threads
+                   ;; they advance from one to the next
+                   ;; once in done, the thread has completed.
+                   (waiting '()) ;; stay here until count(running) < sync-job-cap
+                   (ready   '()) ;; launch jobs in here
+                   (running '()) ;; wait for pid to complete, then move do done
+                   (done    '())) ;; 
+          ;;(print "loop top")
+          (match (thread-receive timeout-seconds 'timeout)
+              ;; (let ((res (thread-receive timeout-seconds 'timeout)
+              ;;        (if (not stop)
+                         
+              ;;            'done)))
+              ;;   res)
+            ('timeout
+             ;;(print "to: "stop" ; next-job-id="next-job-id)
+             (if (and
+                  (not next-job-id) ;; we're draining jobs
+                  (null? waiting)
+                  (null? ready)
+                  (null? running)
+                  )
+                 (begin
+                   (print "Drained.  Done.")
+                   (set! stop #t)
+                   #f)
+                 ;;*** when timeout happens, examine job queues
+                 ;;    and move jobs thru their lifecycle
+                 ;;** count waitings
+                 ;; move min(sync-job-cap - running total, waiting total) to ready
+                 ;; foreach ready, run it
+                 ;;(print "disp: ready="ready)
+                 (begin
+                   (for-each (lambda (job-id)
+                               (let* ((job (hash-table-ref job-hash job-id))
+                                      (job-thread (tjq:job-threadobj job)))
+                                 (tjq:job-state-set! job 'ready)
+                                 (thread-send job-thread 'run)))
+                             ready)
+                   (let* ((new-running (flatten ready running))
+                          (avail-slots (- sync-job-cap (length new-running)))
+                          (queueable-count (min avail-slots (length waiting))))
+                     (let-values (((new-ready new-waiting)
+                                   (split-at waiting queueable-count)))
+                       (loop next-job-id new-waiting new-ready new-running done))))))
+
+            (('job-now-running job-id)
+             (let ((job (hash-table-ref job-hash job-id)))
+               (tjq:job-state-set! job 'running)
+               (loop next-job-id waiting ready running done)))
+            (('job-now-done job-id)
+             (let* ((job (hash-table-ref job-hash job-id))
+                   (successful
+                    (and
+                     (eq? 'normal (tjq:job-normal-exit job))
+                     (zero? (tjq:job-exit-code job))))
+                   (new-running (filter
+                                 (lambda (x) (not (eq? x job-id)))
+                                 running))
+                   (new-done    (cons job-id done)))
+               (tjq:job-state-set! job 'done)
+               (loop next-job-id waiting ready new-running new-done)))
+            (('method 'ping '() return-mbox)
+             (print "got ping")
+             (mailbox-send! return-mbox 'pong)
+             (loop next-job-id waiting ready running done))
+            
+            (('method 'submit args return-mbox)
+             (if (not next-job-id)
+                 (begin
+                   (print "refuse to submit new job -- draining jobs now.")
+                   (mailbox-send! return-mbox #f)
+                   (loop #f waiting ready running done))
+                 (let* ((job-id next-job-id)
+                        (job (apply
+                              make-tjq:job
+                              id: job-id
+                              time-entered-waiting: (current-seconds)
+                              state: 'waiting
+                              args))
+                        (job-thread (tjq:job-thread job-id job this-thread job-thread-timeout-seconds)))
+                   (hash-table-set! job-hash job-id job)
+                   (thread-start! job-thread)
+                   (mailbox-send! return-mbox job-id)
+                   (loop
+                    (add1 next-job-id)
+                    (cons job-id waiting)
+                    ready running done))))
+
+            (('method 'kill)
+             ;; (for-each (job-id)
+             ;;  (lambda (job-id)
+             ;;    (let* ((job (hash-table-ref job-hash job-id))
+             ;;           (job-thread (tjq:job-threadobj job)))
+             ;;      (thread-send job-thread 'abort))
+             )
+            
+            (('method 'drain args return-mbox)
+             (mailbox-send! return-mbox 'drain)
+             (loop #f waiting ready running done))
+                
+                       
+            ;; (for-each
+            ;;   (lambda (job-id)
+            ;;     (let* ((job (hash-table-ref job-hash job-id))
+            ;;            (job-thread (tjq:job-threadobj job)))
+            ;;       (thread-join! job-thread)))
+            ;;   '() ;; FIXME
+            ;;  )
+            
+            (e
+             (print "tjq:dispatcher-thread> no matching pattern.  dispatcher received: ")
+             (pp e)
+             (exit 1))
+            (('method x args return-mbox)
+             (mailbox-send! return-mbox (list 'missing-method))
+             (loop next-job-id waiting ready running done))
+            ) ;; end match
+          ;;(print "Done dispatch thread")
+          #f
+          )))))
+   this-thread))
+  
+
+       
+(define (tjq:new #!key (qname (gensym)) (sync-job-cap 100))
+  (let* ((job-hash (make-hash-table))
+         (obj-mbox (make-mailbox)))
+    (letrec
+        ((dispatch-thread
+          (tjq:dispatcher-thread
+           job-thread-timeout-seconds: 0.01
+           timeout-seconds: 0.01
+
+           qname job-hash sync-job-cap obj))
+         (obj
+          (lambda (op . args)
+            (cond
+             ((eq? op 'event-loop)
+              (print "got event-loop")
+              (thread-join! dispatch-thread)
+              (print "after thread-join dispatch-thread")
+              )
+             ((eq? op 'drain)
+              (thread-send dispatch-thread (list 'method op args obj-mbox))
+              (thread-join! dispatch-thread)
+              (print "Done with queue "qname)
+              #t)
+             (else
+              ;;(print "send method op="op)
+              (thread-send dispatch-thread (list 'method op args obj-mbox))
+              (let* ((res (mailbox-receive! obj-mbox)))
+                (if (eq? res 'missing-method)
+                    (begin
+                      (print "missing method "op" called.")
+                      (tjq:exception 'missing-method))
+                    res)))))
+
+          ) ;; end obj binding
+         ); end letrec bindings
+      (thread-start! dispatch-thread)
+      obj)))
+         
+                            
+(define (test-tjq-simple)
+  (let* ((q (tjq:new qname: 'test-q sync-job-cap: 3)))
+    ;(q 'submit "ls -l")
+    ;(q 'drain)
+
+    (pp (q 'ping))
+    (pp (q 'ping))
+    (thread-sleep! 0.1)
+    ;(q 'event-loop)
+    )
+  )
+
+(define (test-submit)
+  (let* ((q (tjq:new qname: 'test-q sync-job-cap: 3)))
+    (q 'submit cmdline: "sleep 2; echo job well done")
+    (thread-sleep! 4)))
+
+
+(define (test-drain-simple)
+  (let* ((q (tjq:new qname: 'test-q sync-job-cap: 3)))
+    ;(q 'submit cmdline: "sleep 2; echo job well done")
+    (thread-sleep! 1)
+    (q 'drain)))
+  
+
+(define (test-submit-bunch)
+  (let* ((q (tjq:new qname: 'test-q sync-job-cap: 3)))
+    (for-each (lambda (x)
+                (let* ((cmd (conc "echo did job "x)))
+                  (print "submit it--"x)
+                  (q 'submit cmdline: cmd))
+               )
+             (iota 6))
+    ;;(thread-sleep! 10)
+    (q 'drain)
+    ;;(q 'event-loop)
+    ))
+
+(define (test-submit-bunch2)
+  (let* ((q (tjq:new qname: 'test-q sync-job-cap: 20 )))
+    (for-each (lambda (x)
+                ;;(let* ((cmd (conc "echo did job "x)))
+                (let* ((cmd "/bin/true"))
+                  ;;(print "submit it--"x)
+                  (q 'submit cmdline: cmd))
+               )
+             (iota 6000))
+    ;;(thread-sleep! 10)
+    (q 'drain)
+    ;;(q 'event-loop)
+    ))
+
+;(test-tjq-simple)
+;;(test-submit)
+;;(test-drain-simple)
+(print "top")
+(test-submit-bunch)

Index: ezsteps.scm
==================================================================
--- ezsteps.scm
+++ ezsteps.scm
@@ -1,19 +1,27 @@
 
 ;; 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')
 
-(use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking directory-utils)
-(import (prefix sqlite3 sqlite3:))
+(use srfi-1 posix regex srfi-69 directory-utils)
 
 (declare (unit ezsteps))
 (declare (uses db))
 (declare (uses common))
 (declare (uses items))
@@ -37,19 +45,19 @@
 	 (test-id       (db:test-get-id testdat))
 	 (run-id        (db:test-get-run_id testdat))
 	 (test-name     (db:test-get-testname testdat))
 	 (kill-job      #f)) ;; for future use (on re-factoring with launch.scm code
     (let loop ((count 5))
-      (if (file-exists? test-run-dir)
+      (if (common:file-exists? test-run-dir)
 	  (push-directory test-run-dir)
 	  (if (> count 0)
 	      (begin
 		(debug:print 0 *default-log-port* "WARNING: ezsteps attempting to run but test run directory " test-run-dir " is not there. Waiting and trying again " count " more times")
 		(sleep 3)
 		(loop (- count 1))))))
     (debug:print-info 0 *default-log-port* "Running in directory " test-run-dir)
-    (if (not (file-exists? ".ezsteps"))(create-directory ".ezsteps"))
+    (if (not (common:file-exists? ".ezsteps"))(create-directory ".ezsteps"))
     ;; if ezsteps was defined then we are sure to have at least one step but check anyway
     (if (not (> (length ezstepslst) 0))
 	(message-window "ERROR: You can only re-run steps defined via ezsteps")
 	(begin
 	  (let loop ((ezstep   (car ezstepslst))
@@ -75,11 +83,11 @@
 			      (loop (car tal)(cdr tal) stepname #f))))
 
 		  (debug:print 4 *default-log-port* "ezsteps:\n stepname: " stepname " stepinfo: " stepinfo " stepparts: " stepparts
 			       " stepparms: " stepparms " stepcmd: " stepcmd)
 		  
-		  (if (file-exists? (conc stepname ".logpro"))(set! logpro-used #t))
+		  (if (common:file-exists? (conc stepname ".logpro"))(set! logpro-used #t))
 		  
 		  ;; call the command using mt_ezstep
 		  (set! script (conc "mt_ezstep " stepname " " (if prevstep prevstep "-") " " stepcmd))
 		  
 		  (debug:print 4 *default-log-port* "script: " script)

Index: filedb.scm
==================================================================
--- filedb.scm
+++ filedb.scm
@@ -1,13 +1,22 @@
 ;; Copyright 2006-2011, Matthew Welland.
 ;;
-;;  This program is made available under the GNU GPL version 2.0 or
-;;  greater. See the accompanying file COPYING for details.
+;; This 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 program is distributed WITHOUT ANY WARRANTY; without even the
-;;  implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
-;;  PURPOSE.
 
 ;; (require-extension synch sqlite3 posix srfi-13 srfi-1 utils regex)
 (use sqlite3 srfi-1 posix regex srfi-69 srfi-13 posix-extras)
 (import (prefix sqlite3 sqlite3:))
 
@@ -16,11 +25,11 @@
 (include "fdb_records.scm")
 ;; (include "settings.scm")
 
 (define (filedb:open-db dbpath)
   (let* ((fdb      (make-filedb:fdb))
-	 (dbexists (file-exists? dbpath))
+	 (dbexists (common:file-exists? dbpath))
 	 (db (sqlite3:open-database dbpath)))
     (filedb:fdb-set-db!        fdb db)
     (filedb:fdb-set-dbpath!    fdb dbpath)
     (filedb:fdb-set-pathcache! fdb (make-hash-table))
     (filedb:fdb-set-idcache!   fdb (make-hash-table))

DELETED fsl-rebase.scm
Index: fsl-rebase.scm
==================================================================
--- fsl-rebase.scm
+++ /dev/null
@@ -1,37 +0,0 @@
-;; given branch and baseline commit generate list of commands to cherry pick commits
-;;
-;;
-;; Usage: fsl-rebase basecommit branch
-;;         
-
-(use regex posix)
-
-(let* ((basecommit (cadr (argv)))
-       (branch     (caddr (argv)))
-       (cmd        (conc "fossil timeline after " basecommit " -n 1000000 -W 0"))
-       (theregex   (conc ;; "^[^\\]]+"
-			 "\\[([a-z0-9]+)\\]\\s+"
-			 "(.*)"
-			 "\\s+\\(.*tags:\\s+" branch 
-			 ;; ".*\\)"
-			 )))
-  (print "basecommit: " basecommit ", branch: " branch ", theregex: " theregex ", cmd: \"" cmd "\"")
-  (with-input-from-pipe
-   cmd
-   (lambda ()
-     (let loop ((inl (read-line))
-		(res '()))
-       (if (not (eof-object? inl))
-	   (let ((have-match (string-search theregex inl)))
-	     (if have-match
-		 (loop (read-line)
-		       (cons (conc "fossil merge --cherrypick " (cadr have-match)
-				   "\nfossil commit -m \"Cherry pick from " (cadr have-match)
-				   ": " (caddr have-match) "\"")
-			     res))
-		 (loop (read-line) res)))
-	   (map print res))))))
-
-;; (print "match: " inl "\n   $1: " (cadr have-match) " $2: " (caddr have-match))
-;; (print "no match: " theregex " " inl))
-;; (loop (read-line))))))))

ADDED   ftail.scm
Index: ftail.scm
==================================================================
--- /dev/null
+++ ftail.scm
@@ -0,0 +1,99 @@
+;;======================================================================
+;; Copyright 2017, 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.
+;;======================================================================
+
+(declare (unit ftail))
+
+(module ftail
+    (
+     open-tail-db
+     tail-write
+     tail-get-fid
+     file-tail
+     )
+
+(import scheme chicken data-structures extras)
+(use (prefix sqlite3 sqlite3:) posix typed-records)
+
+(define (open-tail-db )
+  (let* ((basedir   (create-directory (conc "/tmp/" (current-user-name))))
+	 (dbpath    (conc basedir "/megatest_logs.db"))
+	 (dbexists  (file-exists? dbpath))
+	 (db        (sqlite3:open-database dbpath))
+	 (handler   (sqlite3:make-busy-timeout 136000)))
+    (sqlite3:set-busy-handler! db handler)
+    (sqlite3:execute db "PRAGMA synchronous = 0;")
+    (if (not dbexists)
+	(begin
+	  (sqlite3:execute db "CREATE TABLE IF NOT EXISTS log_files (id INTEGER PRIMARY KEY,filename TEXT,event_time TIMESTAMP DEFAULT (strftime('%s','now')));")
+	  (sqlite3:execute db "CREATE TABLE IF NOT EXISTS log_data  (id INTEGER PRIMARY KEY,fid INTEGER,line TEXT,event_time TIMESTAMP DEFAULT (strftime('%s','now')));")
+	  ))
+    db))
+
+(define (tail-write db fid lines)
+  (sqlite3:with-transaction
+   db
+   (lambda ()
+     (for-each
+      (lambda (line)
+	(sqlite3:execute db "INSERT INTO log_data (fid,line) VALUES (?,?);" fid line))
+      lines))))
+
+(define (tail-get-fid db fname)
+  (let ((fid   (handle-exceptions
+		   exn
+		   #f
+		 (sqlite3:first-result db "SELECT id FROM log_files WHERE filename=?;" fname))))
+    (if fid
+	fid
+	(begin
+	  (sqlite3:execute db "INSERT INTO log_files (filename) VALUES (?);" fname)
+	  (tail-get-fid db fname)))))
+
+(define (file-tail fname #!key (db-in #f))
+  (let* ((inp (open-input-file fname))
+	 (db  (or db-in (open-tail-db)))
+	 (fid (tail-get-fid db fname)))
+    (let loop ((inl    (read-line inp))
+	       (lines '())
+	       (lastwr (current-seconds)))
+      (if (eof-object? inl)
+	  (let ((timed-out (> (- (current-seconds) lastwr) 60)))
+	    (if timed-out (tail-write db fid (reverse lines)))
+	    (sleep 1)
+	    (if timed-out
+		(loop (read-line inp) '() (current-seconds))
+		(loop (read-line inp) lines lastwr)))
+	  (let* ((savelines (> (length lines) 19)))
+	    ;; (print inl)
+	    (if savelines (tail-write db fid (reverse lines)))
+	    (loop (read-line inp)
+		  (if savelines
+		      '()
+		      (cons inl lines))
+		  (if savelines
+		      (current-seconds)
+		      lastwr)))))))
+
+;; offset -20 means get last 20 lines
+;;
+(define (tail-get-lines db fid offset count)
+  (if (> offset 0)
+      (sqlite3:map-row (lambda (id line)
+		 (vector id line))
+	       db
+	       "SELECT id,line FROM log_data WHERE fid=? OFFSET ? LIMIT ?;" fid offset count)
+      (reverse ;; get N from the end
+       (sqlite3:map-row (lambda (id line)
+		  (vector id line))
+		db
+		"SELECT id,line FROM log_data WHERE fid=? ORDER BY id DESC LIMIT ?;" fid (abs offset)))))
+
+)

Index: gen-data-for-graph.scm
==================================================================
--- gen-data-for-graph.scm
+++ gen-data-for-graph.scm
@@ -1,5 +1,20 @@
+;; 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 foof-loop sql-de-lite posix)
 
 (define beginning-2016 1451636435.0)
 (define now (current-seconds))
 (define one-year-ago (- now (* 365 24 60 60)))

Index: genexample.scm
==================================================================
--- genexample.scm
+++ genexample.scm
@@ -56,11 +56,11 @@
 	(begin
 	  (print "The path " path " does not exist or is not a directory. Attempting to create it now")
 	  (create-directory path #t)))
 
     ;; First check that the directory is empty!
-    (if (and (file-exists? path)
+    (if (and (common:file-exists? path)
 	     (not (null? (glob (conc path "/*")))))
 	(begin
 	  (print "WARNING: directory " path " is not empty, are you sure you want to continue?")
 	  (display "Enter y/n: ")
 	  (if (equal? "y" (read-line))
@@ -210,22 +210,22 @@
 	(scripts  '())
 	(items    '())
 	(rel-path #f))
 
     (cond
-     ((file-exists? "megatest.config")         (set! rel-path "./"))
-     ((file-exists? "../megatest.config")      (set! rel-path "../"))
-     ((file-exists? "../../megatest.config")   (set! rel-path "../../"))
-     ((file-exists? "../../../megatest.config")(set! rel-path "../../../"))) ;; good enough dang it.
+     ((common:file-exists? "megatest.config")         (set! rel-path "./"))
+     ((common:file-exists? "../megatest.config")      (set! rel-path "../"))
+     ((common:file-exists? "../../megatest.config")   (set! rel-path "../../"))
+     ((common:file-exists? "../../../megatest.config")(set! rel-path "../../../"))) ;; good enough dang it.
 
     ;; Don't gather data or continue if a) megatest.config can't be found or b) testconfig already exists
     (if (not rel-path)
 	(begin
 	  (print "ERROR: I could not find megatest.config, please run -create-test in the top dir of your megatest area")
 	  (exit 1)))
 
-    (if (file-exists? (conc rel-path "tests/" testname "/testconfig"))
+    (if (common:file-exists? (conc rel-path "tests/" testname "/testconfig"))
 	(begin
 	  (print "WARNING: You already have a testconfig in " rel-path "tests/" testname ", do you want to clobber your files?")
 	  (display "Enter y/n: ")
 	  (if (not (equal? "y" (read-line)))
 	      (begin

ADDED   get-config-settings.sh
Index: get-config-settings.sh
==================================================================
--- /dev/null
+++ get-config-settings.sh
@@ -0,0 +1,2 @@
+ grep configf:lookup *.scm | sed 's/^.*:lookup//; s/^-number//; s/^ //' | grep -v '^\(section\|test-conf\|tconfig\|testconfig\|dat\|config\|views-cfgdat\)' | perl -pe 's/^\s*(\*configdat\*|configdat|mtconf)//; s/^\s+//; s/\).*$//; s/"//g' | awk '{print $1,$2}' | sort | grep -v section | sort | uniq
+

Index: gutils.scm
==================================================================
--- gutils.scm
+++ gutils.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 .
+;;
 ;;======================================================================
 
 (require-library iup)
 (import (prefix iup iup:))
 (use canvas-draw)
@@ -20,24 +29,36 @@
   (let* ((c1 (map string->number (string-split color1)))
 	 (c2 (map string->number (string-split color2)))
 	 (delta (map (lambda (a b)(abs (- a b))) c1 c2)))
     (null? (filter (lambda (x)(> x 3)) delta))))
 
+(define gutils:colors
+  '((PASS . "70 249 73")
+    (FAIL . "253 33 49")
+    (SKIP . "230 230 0")))
+
+(define (gutils:get-color-spec effective-state)
+  (or (alist-ref effective-state gutils:colors)
+      (alist-ref 'FAIL gutils:colors)))
+
+;; BBnote - state status dashboard button color / text defined here
 (define (gutils:get-color-for-state-status state status);; #!key (get-label #f))
   ;; ((if get-label cadr car)
   (case (string->symbol state)
     ((COMPLETED) ;; ARCHIVED)
      (case (string->symbol status)
        ((PASS)        (list "70  249 73" status))
+       ((PREQ_FAIL PREQ_DISCARDED) (list "255 127 127" status))
        ((WARN WAIVED) (list "255 172 13" status))
-       ((SKIP)        (list "230 230 0" status))
+       ((SKIP)        (list (gutils:get-color-spec 'SKIP) status))
+       ((ABORT)       (list "198 36 166" status))
        (else (list "253 33 49" status))))
     ((ARCHIVED)
      (case (string->symbol status)
        ((PASS)        (list "70  170 73" status))
        ((WARN WAIVED) (list "200 130 13" status))
-       ((SKIP)        (list "180 180 0" status))
+       ((SKIP)        (list (gutils:get-color-spec 'SKIP) status))
        (else (list "180 33 49" status))))
     ;;      (if (equal? status "PASS")
     ;;	  '("70 249 73" "PASS")
     ;;	  (if (or (equal? status "WARN")
     ;;		  (equal? status "WAIVED"))
@@ -44,14 +65,16 @@
     ;;	      (list "255 172 13" status)
     ;;	      (list "223 33 49"  status)))) ;; greenish orangeish redish
     ((LAUNCHED)         (list "101 123 142"  state))
     ((CHECK)            (list "255 100 50"   state))
     ((REMOTEHOSTSTART)  (list "50 130 195"   state))
-    ((RUNNING)          (list "9 131 232"    state))
+    ((RUNNING STARTED)          (list "9 131 232"    state))
     ((KILLREQ)          (list "39 82 206"    state))
     ((KILLED)           (list "234 101 17"   state))
-    ((NOT_STARTED)      (list "240 240 240"  state))
+    ((NOT_STARTED)      (case (string->symbol status)
+			  ((CHECK STARTED)(list (gutils:get-color-spec 'SKIP) state))
+			  (else   (list "240 240 240"                 state))))
     ;; for xor mode below
     ;;
     ((CLEAN)
      (case (string->symbol status)
        ((CLEAN-FAIL CLEAN-CHECK CLEAN-ABORT)  (list "200 130 13" status)) ;; orange requested for these

Index: http-transport.scm
==================================================================
--- http-transport.scm
+++ http-transport.scm
@@ -8,12 +8,12 @@
 ;;  implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
 ;;  PURPOSE.
 
 (require-extension (srfi 18) extras tcp s11n)
 
-(use  srfi-1 posix regex regex-case srfi-69 hostinfo md5 message-digest posix-extras) ;; sqlite3
-;; (import (prefix sqlite3 sqlite3:))
+
+(use  srfi-1 posix regex regex-case srfi-69 hostinfo md5 message-digest posix-extras)
 
 (use spiffy uri-common intarweb http-client spiffy-request-vars intarweb spiffy-directory-listing)
 
 ;; Configurations for server
 (tcp-buffer-size 2048)
@@ -30,21 +30,23 @@
 (declare (uses portlogger))
 (declare (uses rmt))
 
 (include "common_records.scm")
 (include "db_records.scm")
+(include "js-path.scm")
 
+(require-library stml)
 (define (http-transport:make-server-url hostport)
   (if (not hostport)
       #f
       (conc "http://" (car hostport) ":" (cadr hostport))))
 
 (define *server-loop-heart-beat* (current-seconds))
 
 ;;======================================================================
 ;; S E R V E R
-;;======================================================================
+;; ======================================================================
 
 ;; Call this to start the actual server
 ;;
 
 (define *db:process-queue-mutex* (make-mutex))
@@ -57,12 +59,15 @@
 					   ;; (string-intersperse (map number->string (u8vector->list (hostname->ip hostname))) ".")
 					   (server:get-best-guess-address hostname)
 					   #f)))
 			    (if ipstr ipstr hostn))) ;; hostname))) 
 	 (start-port      (portlogger:open-run-close portlogger:find-port))
-	 (link-tree-path  (common:get-linktree))) ;; (configf:lookup *configdat* "setup" "linktree")))
+	 (link-tree-path  (common:get-linktree))
+	 (tmp-area        (common:get-db-tmp-area))
+	 (start-file      (conc tmp-area "/.server-start")))
     (debug:print-info 0 *default-log-port* "portlogger recommended port: " start-port)
+    ;; set some parameters for the server
     (root-path     (if link-tree-path 
 		       link-tree-path
 		       (current-directory))) ;; WARNING: SECURITY HOLE. FIX ASAP!
     (handle-directory spiffy-directory-listing)
     (handle-exception (lambda (exn chain)
@@ -101,29 +106,45 @@
 					   '(/ any))
 				   (send-response body: "hey there!\n"
 						  headers: '((content-type text/plain))))
 				  ((equal? (uri-path (request-uri (current-request))) 
 					   '(/ "hey"))
-				   (send-response body: "hey there!\n"
+				   (send-response body: "hey there!\n" 
 						  headers: '((content-type text/plain))))
+                                  ((equal? (uri-path (request-uri (current-request))) 
+					   '(/ "jquery3.1.0.js"))
+				   (send-response body: (http-transport:show-jquery) 
+						  headers: '((content-type application/javascript))))
+                                  ((equal? (uri-path (request-uri (current-request))) 
+					   '(/ "test_log"))
+				   (send-response body: (http-transport:html-test-log $) 
+						  headers: '((content-type text/HTML))))    
+                                  ((equal? (uri-path (request-uri (current-request))) 
+					   '(/ "dashboard"))
+				   (send-response body: (http-transport:html-dboard $) 
+						  headers: '((content-type text/HTML)))) 
 				  (else (continue))))))))
+    (with-output-to-file start-file (lambda ()(print (current-process-id))))
     (http-transport:try-start-server ipaddrstr start-port)))
 
 ;; This is recursively run by http-transport:run until sucessful
 ;;
 (define (http-transport:try-start-server ipaddrstr portnum)
-  (let ((config-hostname (configf:lookup *configdat* "server" "hostname")))
+  (let ((config-hostname (configf:lookup *configdat* "server" "hostname"))
+	(config-use-proxy (equal? (configf:lookup *configdat* "client" "use-http_proxy") "yes")))
+    (if (not config-use-proxy)
+	(determine-proxy (constantly #f)))
     (debug:print-info 0 *default-log-port* "http-transport:try-start-server time=" (seconds->time-string (current-seconds)) " ipaddrsstr=" ipaddrstr " portnum=" portnum " config-hostname=" config-hostname)
     (handle-exceptions
 	exn
 	(begin
 	  (print-error-message exn)
 	  (if (< portnum 64000)
 	      (begin 
 		(debug:print 0 *default-log-port* "WARNING: attempt to start server failed. Trying again ...")
 		(debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
-		(debug:print 0 *default-log-port* "exn=" (condition->list exn))
+		(debug:print 5 *default-log-port* "exn=" (condition->list exn))
 		(portlogger:open-run-close portlogger:set-failed portnum)
 		(debug:print 0 *default-log-port* "WARNING: failed to start on portnum: " portnum ", trying next port")
 		(thread-sleep! 0.1)
 		
 		;; get_next_port goes here
@@ -233,14 +254,18 @@
 					  (handle-exceptions
 					      exn
 					      (let ((call-chain (get-call-chain))
 						    (msg        ((condition-property-accessor 'exn 'message) exn)))
 						(set! success #f)
-						(debug:print 0 *default-log-port* "WARNING: failure in with-input-from-request to " fullurl ".")
-						(debug:print 0 *default-log-port* " message: " msg)
-						(debug:print 0 *default-log-port* " cmd: " cmd " params: " params)
-						(if runremote
+                                                (if (debug:debug-mode 1)
+                                                    (debug:print-info 0 *default-log-port* "couldn't talk to server, trying again ...")
+                                                    (begin
+                                                      (debug:print 0 *default-log-port* "WARNING: failure in with-input-from-request to " fullurl ".")
+                                                      (debug:print 0 *default-log-port* " message: " msg)
+                                                      (debug:print 0 *default-log-port* " cmd: " cmd " params: " params)
+                                                      (debug:print 0 *default-log-port* " call-chain: " call-chain)))
+                                                (if runremote
 						    (remote-conndat-set! runremote #f))
 						;; Killing associated server to allow clean retry.")
 						;; (tasks:kill-server-run-id run-id)  ;; better to kill the server in the logic that called this routine?
 						(mutex-unlock! *http-mutex*)
 					     ;;; (signal (make-composite-condition
@@ -247,11 +272,11 @@
 					     ;;;          (make-property-condition 'commfail 'message "failed to connect to server")))
 					     ;;; "communications failed"
 						(db:obj->string #f))
 					    (with-input-from-request ;; was dat
 					     fullurl 
-					     (list (cons 'key "thekey")
+					     (list (cons 'key (or *server-id* "thekey"))
 						   (cons 'cmd cmd)
 						   (cons 'params sparams))
 					     read-string))
 					  transport: 'http)
                                          0)) ;; added this speculatively
@@ -292,12 +317,18 @@
 	 (server-dat (if runremote
                          (remote-conndat runremote)
                          #f))) ;; (hash-table-ref/default *runremote* run-id #f)))
     (if (vector? server-dat)
 	(let ((api-dat (http-transport:server-dat-get-api-uri server-dat)))
-	  (close-connection! api-dat)
-	  #t)
+	  (handle-exceptions
+	    exn
+	    (begin
+	      (print-call-chain *default-log-port*)
+	      (debug:print-error 0 *default-log-port* " closing connection failed with error: " ((condition-property-accessor 'exn 'message) exn)))
+	    (close-connection! api-dat)
+            ;;(close-idle-connections!)
+	    #t))
 	#f)))
 
 
 (define (make-http-transport:server-dat)(make-vector 6))
 (define (http-transport:server-dat-get-iface         vec)    (vector-ref  vec 0))
@@ -340,11 +371,13 @@
 (define (http-transport:keep-running) 
   ;; if none running or if > 20 seconds since 
   ;; server last used then start shutdown
   ;; This thread waits for the server to come alive
   (debug:print-info 0 *default-log-port* "Starting the sync-back, keep alive thread in server")
-  (let* ((server-start-time (current-seconds))
+  (let* ((tmp-area          (common:get-db-tmp-area))
+	 (started-file      (conc tmp-area "/.server-started"))
+	 (server-start-time (current-seconds))
 	 (server-info (let loop ((start-time (current-seconds))
 				 (changed    #t)
 				 (last-sdat  "not this"))
                         (let ((sdat #f))
 			  (thread-sleep! 0.01)
@@ -355,36 +388,52 @@
                           (if (and sdat
 				   (not changed)
 				   (> (- (current-seconds) start-time) 2))
 			      (begin
 				(debug:print-info 0 *default-log-port* "Received server alive signature")
+                                (common:save-pkt `((action . alive)
+                                                   (T      . server)
+                                                   (pid    . ,(current-process-id))
+                                                   (ipaddr . ,(car sdat))
+                                                   (port   . ,(cadr sdat)))
+                                                 *configdat* #t)
 				sdat)
                               (begin
 				(debug:print-info 0 *default-log-port* "Still waiting, last-sdat=" last-sdat)
                                 (sleep 4)
 				(if (> (- (current-seconds) start-time) 120) ;; been waiting for two minutes
 				    (begin
 				      (debug:print-error 0 *default-log-port* "transport appears to have died, exiting server")
+                                      (common:save-pkt `((action . died)
+                                                         (T      . server)
+                                                         (pid    . ,(current-process-id))
+                                                         (ipaddr . ,(car sdat))
+                                                         (port   . ,(cadr sdat))
+                                                         (msg    . "Transport died?"))
+                                                 *configdat* #t)
 				      (exit))
 				    (loop start-time
 					  (equal? sdat last-sdat)
 					  sdat)))))))
          (iface       (car server-info))
          (port        (cadr server-info))
          (last-access 0)
-	 (server-timeout (server:get-timeout))
+	 (server-timeout (server:expiration-timeout))
 	 (server-going  #f)
 	 (server-log-file (args:get-arg "-log"))) ;; always set when we are a server
+
+    (with-output-to-file started-file (lambda ()(print (current-process-id))))
+
     (let loop ((count         0)
 	       (server-state 'available)
 	       (bad-sync-count 0)
 	       (start-time     (current-milliseconds)))
       ;; Use this opportunity to sync the tmp db to megatest.db
       (if (not server-going) ;; *dbstruct-db* 
 	  (begin
 	    (debug:print 0 *default-log-port* "SERVER: dbprep")
-	    (set! *dbstruct-db*  (db:setup)) ;;  run-id))
+	    (set! *dbstruct-db*  (db:setup #t)) ;;  run-id))
 	    (set! server-going #t)
 	    (debug:print 0 *default-log-port* "SERVER: running, megatest version: " (common:get-full-version)) ;; NOTE: the server is NOT yet marked as running in the log. We do that in the keep-running routine.
 	    (thread-start! *watchdog*)))
       
       ;; when things go wrong we don't want to be doing the various queries too often
@@ -423,28 +472,23 @@
 	    (flush-output *default-log-port*)))
       (if (common:low-noise-print 60 "dbstats")
 	  (begin
 	    (debug:print 0 *default-log-port* "Server stats:")
 	    (db:print-current-query-stats)))
-      (let* ((hrs-since-start  (/ (- (current-seconds) server-start-time) 3600))
-	     (adjusted-timeout (if (> hrs-since-start 1)
-				   (- server-timeout (inexact->exact (round (* hrs-since-start 60))))  ;; subtract 60 seconds per hour
-				   server-timeout)))
-	(if (common:low-noise-print 120 "server timeout")
-	    (debug:print-info 0 *default-log-port* "Adjusted server timeout: " adjusted-timeout))
+      (let* ((hrs-since-start  (/ (- (current-seconds) server-start-time) 3600)))
 	(cond
          ((and *server-run*
 	       (> (+ last-access server-timeout)
-		  (current-seconds))
-	       (< (- (current-seconds) server-start-time) 3600)) ;; do not update log or touch log if we've been running for more than one hour.
+		  (current-seconds)))
           (if (common:low-noise-print 120 "server continuing")
               (debug:print-info 0 *default-log-port* "Server continuing, seconds since last db access: " (- (current-seconds) last-access))
 	      (let ((curr-time (current-seconds)))
 		(handle-exceptions
 		    exn
 		    (debug:print 0 *default-log-port* "ERROR: Failed to change timestamp on log file " server-log-file ". Are you out of space on that disk?")
-		  (change-file-times server-log-file curr-time curr-time))))
+		  (if (not *server-overloaded*)
+		      (change-file-times server-log-file curr-time curr-time)))))
           (loop 0 server-state bad-sync-count (current-milliseconds)))
          (else
           (debug:print-info 0 *default-log-port* "Server timed out. seconds since last db access: " (- (current-seconds) last-access))
           (http-transport:server-shutdown port)))))))
 
@@ -474,66 +518,128 @@
     ;; 			  (/ *total-non-write-delay* 
     ;; 			     *number-non-write-queries*))
     ;; 		      " ms")
     
     (db:print-current-query-stats)
-    
+    (common:save-pkt `((action . exit)
+                       (T      . server)
+                       (pid    . ,(current-process-id)))
+                     *configdat* #t)
     (debug:print-info 0 *default-log-port* "Server shutdown complete. Exiting")
     (exit)))
 
 ;; all routes though here end in exit ...
 ;;
 ;; start_server? 
 ;;
 (define (http-transport:launch)
-  ;; (if (args:get-arg "-daemonize")
-  ;;     (begin
-  ;; 	(daemon:ize)
-  ;; 	(if *alt-log-file* ;; we should re-connect to this port, I think daemon:ize disrupts it
-  ;; 	    (begin
-  ;; 	      (current-error-port *alt-log-file*)
-  ;; 	      (current-output-port *alt-log-file*)))))
-  (let* ((th2 (make-thread (lambda ()
-			     (debug:print-info 0 *default-log-port* "Server run thread started")
-			     (http-transport:run 
-			      (if (args:get-arg "-server")
-				  (args:get-arg "-server")
-				  "-")
-			      )) "Server run"))
-	 (th3 (make-thread (lambda ()
-			     (debug:print-info 0 *default-log-port* "Server monitor thread started")
-			     (http-transport:keep-running)
-			   "Keep running"))))
-    (thread-start! th2)
-    (thread-sleep! 0.25) ;; give the server time to settle before starting the keep-running monitor.
-    (thread-start! th3)
-    (set! *didsomething* #t)
-    (thread-join! th2)
-    (exit)))
-
-(define (http-transport:server-signal-handler signum)
-  (signal-mask! signum)
-  (handle-exceptions
-   exn
-   (debug:print 0 *default-log-port* " ... exiting ...")
-   (let ((th1 (make-thread (lambda ()
-			     (thread-sleep! 1))
-			   "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! 3) ;; give the flush three seconds 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))))
+  ;; check that a server start is in progress, pause or exit if so
+  (let* ((tmp-area            (common:get-db-tmp-area))
+	 (server-start        (conc tmp-area "/.server-start"))
+	 (server-started      (conc tmp-area "/.server-started"))
+	 (start-time          (common:lazy-modification-time server-start))
+	 (started-time        (common:lazy-modification-time server-started))
+	 (server-starting     (< start-time started-time)) ;; if start-time is less than started-time then a server is still starting
+	 (start-time-old      (> (- (current-seconds) start-time) 5))
+         (cleanup-proc        (lambda (msg)
+                                (let* ((serv-fname      (conc "server-" (current-process-id) "-" (get-host-name) ".log"))
+                                       (full-serv-fname (conc *toppath* "/logs/" serv-fname))
+                                       (new-serv-fname  (conc *toppath* "/logs/" "defunct-" serv-fname)))
+                                  (debug:print 0 *default-log-port* msg)
+                                  (if (common:file-exists? full-serv-fname)
+                                      (system (conc "sleep 1;mv -f " full-serv-fname " " new-serv-fname))
+                                      (debug:print 0 *default-log-port* "INFO: cannot move " full-serv-fname " to " new-serv-fname))
+                                  (exit)))))
+    (if (and (not start-time-old) ;; last server start try was less than five seconds ago
+	     (not server-starting))
+	(begin
+	  (cleanup-proc "NOT starting server, there is either a recently started server or a server in process of starting")
+	  (exit)))
+    ;; lets not even bother to start if there are already three or more server files ready to go
+    (let* ((num-alive   (server:get-num-alive (server:get-list *toppath*))))
+      (if (> num-alive 3)
+          (begin
+            (cleanup-proc (conc "ERROR: Aborting server start because there are already " num-alive " possible servers either running or starting up"))
+            (exit))))
+  (common:save-pkt `((action . start)
+		     (T      . server)
+		     (pid    . ,(current-process-id)))
+		   *configdat* #t)
+    (let* ((th2 (make-thread (lambda ()
+                               (debug:print-info 0 *default-log-port* "Server run thread started")
+                               (http-transport:run 
+                                (if (args:get-arg "-server")
+                                    (args:get-arg "-server")
+                                    "-")
+                                )) "Server run"))
+           (th3 (make-thread (lambda ()
+                               (debug:print-info 0 *default-log-port* "Server monitor thread started")
+                               (http-transport:keep-running)
+                               "Keep running"))))
+      (thread-start! th2)
+      (thread-sleep! 0.25) ;; give the server time to settle before starting the keep-running monitor.
+      (thread-start! th3)
+      (set! *didsomething* #t)
+      (thread-join! th2)
+      (exit))))
+
+;; (define (http-transport:server-signal-handler signum)
+;;   (signal-mask! signum)
+;;   (handle-exceptions
+;;    exn
+;;    (debug:print 0 *default-log-port* " ... exiting ...")
+;;    (let ((th1 (make-thread (lambda ()
+;; 			     (thread-sleep! 1))
+;; 			   "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! 3) ;; give the flush three seconds 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))))
+
+;;===============================================
+;; Java script
+;;===============================================
+(define (http-transport:show-jquery)
+  (let* ((data  (tests:readlines *java-script-lib*)))
+(string-join data "\n")))
+
+
 
 ;;======================================================================
 ;; web pages
 ;;======================================================================
 
+(define (http-transport:html-test-log $)
+   (let* ((run-id ($ 'runid))
+         (test-item ($ 'testname))
+         (parts (string-split test-item ":"))
+         (test-name (car parts))
+             
+         (item-name (if (equal? (length parts) 1)
+             ""
+             (cadr parts))))
+  ;(print $) 
+(tests:get-test-log run-id test-name item-name)))
+
+
+(define (http-transport:html-dboard $)
+  (let* ((page ($ 'page))
+         (oup       (open-output-string)) 
+         (bdy "--------------------------")
+
+         (ret  (tests:dynamic-dboard page)))
+    (s:output-new  oup  ret)
+   (close-output-port oup)
+
+  (set! bdy   (get-output-string oup))
+     (conc "
Dashboard
" bdy "
 
 "  )))
+
 (define (http-transport:main-page)
   (let ((linkpath (root-path)))
     (conc "
" (pathname-strip-directory *toppath*) "
"
 	  ""
 	  "Run area: " *toppath*

Index: index-tree.scm
==================================================================
--- index-tree.scm
+++ index-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 .
+;;
 ;;======================================================================
 
 ;;======================================================================
 ;; Tests
 ;;======================================================================

Index: items.scm
==================================================================
--- items.scm
+++ items.scm
@@ -132,12 +132,12 @@
     (set! itemstable (map (lambda (item)
 			    (if (procedure? (cadr item))
 				(list (car item)((cadr item)))  ;; evaluate the proc
 				item))
 			  itemstable))
-    (if (and have-items  (null? items))     (debug:print-error 0 *default-log-port* "[items] section in testconfig but no entries defined"))
-    (if (and have-itable (null? itemstable))(debug:print-error 0 *default-log-port* "[itemstable] section in testconfig but no entries defined"))
+    (if (and have-items  (null? items))     (debug:print 0 *default-log-port* "WARNING:[items] section in testconfig but no entries defined"))
+    (if (and have-itable (null? itemstable))(debug:print 0 *default-log-port* "WARNNG:[itemstable] section in testconfig but no entries defined"))
     (if (or (not (null? items))(not (null? itemstable)))
 	(append (item-assoc->item-list items)
 		(item-table->item-list itemstable))
 	'(()))))
 

DELETED iupexamples/graph.scm
Index: iupexamples/graph.scm
==================================================================
--- iupexamples/graph.scm
+++ /dev/null
@@ -1,62 +0,0 @@
-(use iup)
-(import iup-pplot)
-
- 
-
-(define (tl)
-  (let* ((lastx 0)
-	 (lastsample 2)
-	 (plt (pplot 
-	       #:title "MyTitle"
-	       #:marginbottom "65"
-	       #:marginleft   "65"
-	       #:axs_xlabel   "Score" 
-	       #:axs_ylabel "Count"
-	       #:legendshow "YES"
-	       ;; #:axs_xmin    "0"
-	       ;; #:axs_ymin    "0"
-	       #:axs_yautomin "YES"
-	       #:axs_xautomin "YES"
-	       #:axs_xautotick "YES"
-	       #:axs_yautotick "YES"
-	       #:ds_showvalues "YES"
-	       #:size "200x200"
-	       ))
-	 (plt1  (call-with-pplot 
-		 plt
-		 (lambda (x)
-		   (pplot-add! plt 10 100)
-		   (pplot-add! plt 20 120)
-		   (pplot-add! plt 30 200))
-		 #:x-string #f
-		 ))
-	 (plt2  (call-with-pplot 
-		 plt
-		 (lambda (x)
-		   (pplot-add! plt 10 180)
-		   (pplot-add! plt 20 125)
-		   (pplot-add! plt 30 100))
-		 #:x-string #f
-		 ))
-	 (dlg (dialog
-	       (vbox
-		plt
-		(hbox
-		;;  (button "Redraw" size: "50x" action: (lambda (obj)
-		;; 					(redraw plt)))
-		 (button "Quit"   size: "50x" action: (lambda (obj)
-							(exit)))
-		 (button "AddPoint" size: "50x" action: (lambda (obj)
-							  (set! lastx (+ lastx 10))
-							  (set! lastsample (+ lastsample 1))
-							  ;; (attribute-set! plt 'current 0)
-							  (print "lastx: " lastx " lastsample: " lastsample)
-							  (pplot-add! plt lastx (random 300) lastsample 1)
-							  (attribute-set! plt "REDRAW" "1"))))))))
-    (set! lastx 30)
-    (attribute-set! plt 'ds_mode "LINE")
-    ;; (attribute-set! plt 'ds_legend "Yada")
-    (show dlg)
-    (main-loop)))
-
-(tl)

DELETED iupexamples/iupwidgetinfo.scm
Index: iupexamples/iupwidgetinfo.scm
==================================================================
--- iupexamples/iupwidgetinfo.scm
+++ /dev/null
@@ -1,191 +0,0 @@
-#! /usr/bin/env csi
-
-(require-library srfi-4 iup)
-(import srfi-4 iup iup-pplot iup-glcanvas)
-
-(define (popup dlg . args)
-  (apply show dlg #:modal? 'yes args)
-  (destroy! dlg))
-
-(define (properties ih)
-  (popup (element-properties-dialog ih))
-  'default)
-
-(define dlg
-  (dialog
-    (vbox
-      (hbox ; headline
-        (fill)
-        (frame (label " Inspect control and dialog classes "
-                      fontsize: 15))
-        (fill)
-        margin: '0x0)
-
-      (label "") 
-      (label "Dialogs" fontsize: 12)
-      (hbox
-        (button "dialog"
-                action: (lambda (self) (properties (dialog (vbox)))))
-        (button "color-dialog"
-                action: (lambda (self) (properties (color-dialog))))
-        (button "file-dialog"
-                action: (lambda (self) (properties (file-dialog))))
-        (button "font-dialog"
-                action: (lambda (self) (properties (font-dialog))))
-        (button "message-dialog"
-                action: (lambda (self) (properties (message-dialog))))
-        (fill)
-        margin: '0x0)
-      (hbox
-        (button "layout-dialog"
-                action: (lambda (self) (properties (layout-dialog))))
-        (button "element-properties-dialog"
-                action: (lambda (self)
-                          (properties
-                            (element-properties-dialog (create 'user)))))
-        (fill)
-        margin: '0x0)
-
-      (label "") 
-      (label "Composition widgets" fontsize: 12)
-      (hbox
-        (button "fill"
-                action: (lambda (self) (properties (fill))))
-        (button "hbox"
-                action: (lambda (self) (properties (hbox))))
-        (button "vbox"
-                action: (lambda (self) (properties (vbox))))
-        (button "zbox"
-                action: (lambda (self) (properties (zbox))))
-        (button "radio"
-                action: (lambda (self) (properties (radio (vbox)))))
-        (button "normalizer"
-                action: (lambda (self) (properties (normalizer))))
-        (button "cbox"
-                action: (lambda (self) (properties (cbox))))
-        (button "sbox"
-                action: (lambda (self) (properties (sbox (vbox)))))
-        (button "split"
-                action: (lambda (self) (properties (split (vbox) (vbox)))))
-        (fill)
-        margin: '0x0)
-
-      (label "") 
-      (label "Standard widgets" fontsize: 12)
-      (hbox
-        (button "button"
-                action: (lambda (self) (properties (button))))
-        (button "canvas"
-                action: (lambda (self) (properties (canvas))))
-        (button "frame"
-                action: (lambda (self) (properties (frame))))
-        (button "label"
-                action: (lambda (self) (properties (label))))
-        (button "listbox"
-                action: (lambda (self) (properties (listbox))))
-        (button "progress-bar"
-                action: (lambda (self) (properties (progress-bar))))
-        (button "spin"
-                action: (lambda (self) (properties (spin))))
-        (fill)
-        margin: '0x0)
-      (hbox
-        (button "tabs"
-                action: (lambda (self) (properties (tabs))))
-        (button "textbox"
-                action: (lambda (self) (properties (textbox))))
-        (button "toggle"
-                action: (lambda (self) (properties (toggle))))
-        (button "treebox"
-                action: (lambda (self) (properties (treebox))))
-        (button "valuator"
-                action: (lambda (self) (properties (valuator ""))))
-        (fill)
-        margin: '0x0)
-
-      (label "") 
-      (label "Additional widgets" fontsize: 12)
-      (hbox
-        (button "cells"
-                action: (lambda (self) (properties (cells))))
-        (button "color-bar"
-                action: (lambda (self) (properties (color-bar))))
-        (button "color-browser"
-                action: (lambda (self) (properties (color-browser))))
-        (button "dial"
-                action: (lambda (self) (properties (dial ""))))
-        (button "matrix"
-                action: (lambda (self) (properties (matrix))))
-        (fill)
-        margin: '0x0)
-      (hbox
-        (button "pplot"
-                action: (lambda (self) (properties (pplot))))
-        (button "glcanvas"
-                action: (lambda (self) (properties (glcanvas))))
-        (button "web-browser"
-                action: (lambda (self) (properties (web-browser))))
-        (fill)
-        margin: '0x0)
-
-      (label "") 
-      (label "Menu widgets" fontsize: 12)
-      (hbox
-        (button "menu"
-                action: (lambda (self) (properties (menu))))
-        (button "menu-item"
-                action: (lambda (self) (properties (menu-item))))
-        (button "menu-separator"
-                action: (lambda (self) (properties (menu-separator))))
-        (fill)
-        margin: '0x0)
-
-      (label "") 
-      (label "Images" fontsize: 12)
-      (hbox
-        (button "image/palette"
-                action: (lambda (self)
-                          (properties
-                            (image/palette 1 1 (u8vector->blob (u8vector 0))))))
-        (button "image/rgb"
-                action: (lambda (self)
-                          (properties
-                            (image/rgb 1 1 (u8vector->blob (u8vector 0))))))
-        (button "image/rgba"
-                action: (lambda (self)
-                          (properties
-                            (image/rgba 1 1 (u8vector->blob (u8vector 0))))))
-        (button "image/file"
-                action: (lambda (self)
-                          (properties
-                            ;; same attributes as image/palette
-                            (image/palette 1 1 (u8vector->blob (u8vector 0))))))
-                            ;; needs a file in current directory
-                            ;(image/file "chicken.ico")))) ; ok
-                            ;(image/file "chicken.png")))) ; doesn't work
-        (fill)
-        margin: '0x0)
-
-      (label "") 
-      (label "Other widgets" fontsize: 12)
-      (hbox
-        (button "clipboard"
-                action: (lambda (self) (properties (clipboard))))
-        (button "timer"
-                action: (lambda (self) (properties (timer))))
-        (button "spinbox"
-                action: (lambda (self) (properties (spinbox (vbox)))))
-        (fill)
-        margin: '0x0)
-
-      (fill)
-      (button "E&xit"
-              expand: 'horizontal
-              action: (lambda (self) 'close))
-      )
-    margin: '15x15
-    title: "Iup inspector"))
-
-(show dlg)
-(main-loop)
-(exit 0)

DELETED iupexamples/tree.scm
Index: iupexamples/tree.scm
==================================================================
--- iupexamples/tree.scm
+++ /dev/null
@@ -1,145 +0,0 @@
-
-(use test)
-(require-library iup)
-(import (prefix iup iup:))
-
-(define t #f) 
-
-(define tree-dialog
-  (iup:dialog
-   #:title "Tree Test"
-   (let ((t1 (iup:treebox
-	      #:selection_cb (lambda (obj id state)
-			       (print "selection_db with id=" id " state=" state)
-			       (print "USERDATA: " (iup:attribute obj "USERDATA"))
-			       (print "SPECIALDATA: " (iup:attribute obj "SPECIALDATA"))
-			       (print "Depth: " (iup:attribute obj "DEPTH"))
-			       ))))
-     (set! t t1)
-     t1)))
-
-(iup:show tree-dialog)
-
-(map (lambda (elname el)
-       (print "Adding " elname " with value " el)
-       (iup:attribute-set! t elname el)
-       (iup:attribute-set! t "USERDATA" el))
-     '("VALUE" "NAME"    "ADDLEAF" "ADDBRANCH1" "ADDLEAF2"    "VALUE")
-     '("0"     "Figures" "Other"   "triangle"   "equilateral" "4")
-     )
-(map (lambda (attr)
-       (print attr " is " (iup:attribute t attr)))
-     '("KIND1" "PARENT2" "STATE1"))
-
-(define (tree-find-node obj path)
-  ;; start at the base of the tree
-  (if (null? path)
-      #f ;; or 0 ????
-      (let loop ((hed      (car path))
-		 (tal      (cdr path))
-		 (depth    0)
-		 (nodenum  0))
-	;; nodes in iup tree are 100% sequential so iterate over nodenum
-	(if (iup:attribute obj (conc "DEPTH" nodenum)) ;; end when no more nodes
-	    (let ((node-depth (string->number (iup:attribute obj (conc "DEPTH" nodenum))))
-		  (node-title (iup:attribute obj (conc "TITLE" nodenum))))
-	      ;; (print 0 "hed: " hed ", depth: " depth ", node-depth: " node-depth ", nodenum: " nodenum ", node-title: " node-title)
-	      (if (and (equal? depth node-depth)
-		       (equal? hed   node-title)) ;; yep, this is the one!
-		  (if (null? tal) ;; end of the line
-		      nodenum
-		      (loop (car tal)(cdr tal)(+ depth 1)(+ 1 nodenum)))
-		  ;; this is the case where we found part of the hierarchy but not 
-		  ;; all of it, i.e. the node-depth went from deep to less deep
-		  (if (> depth node-depth) ;; (+ 1 node-depth))
-		      #f
-		      (loop hed tal depth (+ nodenum 1)))))
-	    #f))))
-
-;; top is the top node name zeroeth node VALUE=0
-(define (tree-add-node obj top nodelst)
-  (if (not (iup:attribute obj "TITLE0"))
-      (iup:attribute-set! obj "ADDBRANCH0" top))
-  (cond
-   ((not (string=? top (iup:attribute obj "TITLE0")))
-    (print "ERROR: top name " top " doesn't match " (iup:attribute obj "TITLE0")))
-   ((null? nodelst))
-   (else
-    (let loop ((hed      (car nodelst))
-	       (tal      (cdr nodelst))
-	       (depth    1)
-	       (pathl    (list top)))
-      ;; Because the tree dialog changes node numbers when
-      ;; nodes are added or removed we must look up nodes
-      ;; each and every time. 0 is the top node so default
-      ;; to that.
-      (let* ((newpath    (append pathl (list hed)))
-	       (parentnode (tree-find-node obj pathl))
-	       (nodenum    (tree-find-node obj newpath)))
-	  ;; (print "newpath: " newpath ", nodenum " nodenum ", hed: " hed ", depth: " depth ", parentnode: " parentnode ", pathl: " pathl)
-	  ;; Add the branch under lastnode if not found
-	  (if (not nodenum)
-	      (begin
-		(iup:attribute-set! obj (conc "ADDBRANCH" parentnode) hed)
-		(if (null? tal)
-		    #t
-		    ;; reset to top
-		    (loop (car nodelst)(cdr nodelst) 1 (list top)))) 
-	      (if (null? tal) ;; if null here then this path has already been added
-		  #t
-		  ;; (if nodenum
-		  (loop (car tal)(cdr tal)(+ depth 1) newpath)))))))) ;;  (if nodenum nodenum lastnode)))))))
-	      ;; 	  (loop hed tal depth pathl lastnode)))))))
-
-(define (tree-node->path obj nodenum)
-  ;; (print "\ncurrnode  nodenum  depth  node-depth  node-title   path")
-  (let loop ((currnode 0)
-	     (depth    0)
-	     (path     '()))
-    (let ((node-depth (iup:attribute obj (conc "DEPTH" currnode)))
-	  (node-title (iup:attribute obj (conc "TITLE" currnode))))
-      ;; (display (conc "\n   "currnode "        " nodenum "       " depth "         " node-depth "          " node-title "         " path))
-      (if (> currnode nodenum)
-	  path
-	  (if (not node-depth) ;; #f if we are out of nodes
-	      '()
-	      (let ((ndepth (string->number node-depth)))
-		(if (eq? ndepth depth)
-		    ;; This next is the match condition depth == node-depth
-		    (if (eq? currnode nodenum)
-			(begin
-			  ;; (display " ")
-			  (append path (list node-title)))
-			(loop (+ currnode 1)
-			      (+ depth 1)
-			      (append path (list node-title))))
-		    ;; didn't match, reset to base path and keep looking
-		    ;; due to more iup odditys we don't reset to base
-		    (begin 
-		      ;; (display " ")
-		      (loop (+ 1 currnode)
-			    2
-			    (append (take path ndepth)(list node-title)))))))))))
-
-(test #f 0  (tree-find-node t '("Figures")))
-(test #f 1  (tree-find-node t '("Figures" "Other")))
-(test #f #f (tree-find-node t '("Figures" "Other"    "equilateral")))
-(test #f 3  (tree-find-node t '("Figures" "triangle" "equilateral")))
-(test #f #t (tree-add-node  t "Figures" '()))
-(test #f #t (tree-add-node  t "Figures" '("a" "b" "c")))
-(test #f 3  (tree-find-node t '("Figures" "a" "b" "c")))
-(test #f #t (tree-add-node  t "Figures" '("d" "b" "c")))
-(test #f 3  (tree-find-node t '("Figures" "d" "b" "c")))
-(test #f 6  (tree-find-node t '("Figures" "a" "b" "c")))
-(test #f #t (tree-add-node  t "Figures" '("a" "e" "c")))
-(test #f 6  (tree-find-node t '("Figures" "a" "e" "c")))
-
-(test #f '("Figures")             (tree-node->path t 0))
-(test #f '("Figures" "d")         (tree-node->path t 1))
-(test #f '("Figures" "d" "b" "c") (tree-node->path t 3))
-(test #f '("Figures" "a")         (tree-node->path t 4))
-(test #f '("Figures" "a" "b" "c")     (tree-node->path t 8)) 
-(test #f '()                      (tree-node->path t 40))
-
-(iup:main-loop)
-

ADDED   java-script-lib/jquery-3.1.0.slim.min.js
Index: java-script-lib/jquery-3.1.0.slim.min.js
==================================================================
--- /dev/null
+++ java-script-lib/jquery-3.1.0.slim.min.js
@@ -0,0 +1,4 @@
+/*! jQuery v3.1.0 -ajax,-ajax/jsonp,-ajax/load,-ajax/parseXML,-ajax/script,-ajax/var/location,-ajax/var/nonce,-ajax/var/rquery,-ajax/xhr,-manipulation/_evalUrl,-event/ajax,-effects,-effects/Tween,-effects/animatedSelector,-deprecated | (c) jQuery Foundation | jquery.org/license */
+!function(a,b){"use strict";"object"==typeof module&&"object"==typeof module.exports?module.exports=a.document?b(a,!0):function(a){if(!a.document)throw new Error("jQuery requires a window with a document");return b(a)}:b(a)}("undefined"!=typeof window?window:this,function(a,b){"use strict";var c=[],d=a.document,e=Object.getPrototypeOf,f=c.slice,g=c.concat,h=c.push,i=c.indexOf,j={},k=j.toString,l=j.hasOwnProperty,m=l.toString,n=m.call(Object),o={};function p(a,b){b=b||d;var c=b.createElement("script");c.text=a,b.head.appendChild(c).parentNode.removeChild(c)}var q="3.1.0 -ajax,-ajax/jsonp,-ajax/load,-ajax/parseXML,-ajax/script,-ajax/var/location,-ajax/var/nonce,-ajax/var/rquery,-ajax/xhr,-manipulation/_evalUrl,-event/ajax,-effects,-effects/Tween,-effects/animatedSelector,-deprecated",r=function(a,b){return new r.fn.init(a,b)},s=/^[\s\uFEFF\xA0]+|[\s\uFEFF\xA0]+$/g,t=/^-ms-/,u=/-([a-z])/g,v=function(a,b){return b.toUpperCase()};r.fn=r.prototype={jquery:q,constructor:r,length:0,toArray:function(){return f.call(this)},get:function(a){return null!=a?a<0?this[a+this.length]:this[a]:f.call(this)},pushStack:function(a){var b=r.merge(this.constructor(),a);return b.prevObject=this,b},each:function(a){return r.each(this,a)},map:function(a){return this.pushStack(r.map(this,function(b,c){return a.call(b,c,b)}))},slice:function(){return this.pushStack(f.apply(this,arguments))},first:function(){return this.eq(0)},last:function(){return this.eq(-1)},eq:function(a){var b=this.length,c=+a+(a<0?b:0);return this.pushStack(c>=0&&c0&&b-1 in a)}var x=function(a){var b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u="sizzle"+1*new Date,v=a.document,w=0,x=0,y=ha(),z=ha(),A=ha(),B=function(a,b){return a===b&&(l=!0),0},C={}.hasOwnProperty,D=[],E=D.pop,F=D.push,G=D.push,H=D.slice,I=function(a,b){for(var c=0,d=a.length;c+~]|"+K+")"+K+"*"),S=new RegExp("="+K+"*([^\\]'\"]*?)"+K+"*\\]","g"),T=new RegExp(N),U=new RegExp("^"+L+"$"),V={ID:new RegExp("^#("+L+")"),CLASS:new RegExp("^\\.("+L+")"),TAG:new RegExp("^("+L+"|[*])"),ATTR:new RegExp("^"+M),PSEUDO:new RegExp("^"+N),CHILD:new RegExp("^:(only|first|last|nth|nth-last)-(child|of-type)(?:\\("+K+"*(even|odd|(([+-]|)(\\d*)n|)"+K+"*(?:([+-]|)"+K+"*(\\d+)|))"+K+"*\\)|)","i"),bool:new RegExp("^(?:"+J+")$","i"),needsContext:new RegExp("^"+K+"*[>+~]|:(even|odd|eq|gt|lt|nth|first|last)(?:\\("+K+"*((?:-\\d)?\\d*)"+K+"*\\)|)(?=[^-]|$)","i")},W=/^(?:input|select|textarea|button)$/i,X=/^h\d$/i,Y=/^[^{]+\{\s*\[native \w/,Z=/^(?:#([\w-]+)|(\w+)|\.([\w-]+))$/,$=/[+~]/,_=new RegExp("\\\\([\\da-f]{1,6}"+K+"?|("+K+")|.)","ig"),aa=function(a,b,c){var d="0x"+b-65536;return d!==d||c?b:d<0?String.fromCharCode(d+65536):String.fromCharCode(d>>10|55296,1023&d|56320)},ba=/([\0-\x1f\x7f]|^-?\d)|^-$|[^\x80-\uFFFF\w-]/g,ca=function(a,b){return b?"\0"===a?"\ufffd":a.slice(0,-1)+"\\"+a.charCodeAt(a.length-1).toString(16)+" ":"\\"+a},da=function(){m()},ea=ta(function(a){return a.disabled===!0},{dir:"parentNode",next:"legend"});try{G.apply(D=H.call(v.childNodes),v.childNodes),D[v.childNodes.length].nodeType}catch(fa){G={apply:D.length?function(a,b){F.apply(a,H.call(b))}:function(a,b){var c=a.length,d=0;while(a[c++]=b[d++]);a.length=c-1}}}function ga(a,b,d,e){var f,h,j,k,l,o,r,s=b&&b.ownerDocument,w=b?b.nodeType:9;if(d=d||[],"string"!=typeof a||!a||1!==w&&9!==w&&11!==w)return d;if(!e&&((b?b.ownerDocument||b:v)!==n&&m(b),b=b||n,p)){if(11!==w&&(l=Z.exec(a)))if(f=l[1]){if(9===w){if(!(j=b.getElementById(f)))return d;if(j.id===f)return d.push(j),d}else if(s&&(j=s.getElementById(f))&&t(b,j)&&j.id===f)return d.push(j),d}else{if(l[2])return G.apply(d,b.getElementsByTagName(a)),d;if((f=l[3])&&c.getElementsByClassName&&b.getElementsByClassName)return G.apply(d,b.getElementsByClassName(f)),d}if(c.qsa&&!A[a+" "]&&(!q||!q.test(a))){if(1!==w)s=b,r=a;else if("object"!==b.nodeName.toLowerCase()){(k=b.getAttribute("id"))?k=k.replace(ba,ca):b.setAttribute("id",k=u),o=g(a),h=o.length;while(h--)o[h]="#"+k+" "+sa(o[h]);r=o.join(","),s=$.test(a)&&qa(b.parentNode)||b}if(r)try{return G.apply(d,s.querySelectorAll(r)),d}catch(x){}finally{k===u&&b.removeAttribute("id")}}}return i(a.replace(P,"$1"),b,d,e)}function ha(){var a=[];function b(c,e){return a.push(c+" ")>d.cacheLength&&delete b[a.shift()],b[c+" "]=e}return b}function ia(a){return a[u]=!0,a}function ja(a){var b=n.createElement("fieldset");try{return!!a(b)}catch(c){return!1}finally{b.parentNode&&b.parentNode.removeChild(b),b=null}}function ka(a,b){var c=a.split("|"),e=c.length;while(e--)d.attrHandle[c[e]]=b}function la(a,b){var c=b&&a,d=c&&1===a.nodeType&&1===b.nodeType&&a.sourceIndex-b.sourceIndex;if(d)return d;if(c)while(c=c.nextSibling)if(c===b)return-1;return a?1:-1}function ma(a){return function(b){var c=b.nodeName.toLowerCase();return"input"===c&&b.type===a}}function na(a){return function(b){var c=b.nodeName.toLowerCase();return("input"===c||"button"===c)&&b.type===a}}function oa(a){return function(b){return"label"in b&&b.disabled===a||"form"in b&&b.disabled===a||"form"in b&&b.disabled===!1&&(b.isDisabled===a||b.isDisabled!==!a&&("label"in b||!ea(b))!==a)}}function pa(a){return ia(function(b){return b=+b,ia(function(c,d){var e,f=a([],c.length,b),g=f.length;while(g--)c[e=f[g]]&&(c[e]=!(d[e]=c[e]))})})}function qa(a){return a&&"undefined"!=typeof a.getElementsByTagName&&a}c=ga.support={},f=ga.isXML=function(a){var b=a&&(a.ownerDocument||a).documentElement;return!!b&&"HTML"!==b.nodeName},m=ga.setDocument=function(a){var b,e,g=a?a.ownerDocument||a:v;return g!==n&&9===g.nodeType&&g.documentElement?(n=g,o=n.documentElement,p=!f(n),v!==n&&(e=n.defaultView)&&e.top!==e&&(e.addEventListener?e.addEventListener("unload",da,!1):e.attachEvent&&e.attachEvent("onunload",da)),c.attributes=ja(function(a){return a.className="i",!a.getAttribute("className")}),c.getElementsByTagName=ja(function(a){return a.appendChild(n.createComment("")),!a.getElementsByTagName("*").length}),c.getElementsByClassName=Y.test(n.getElementsByClassName),c.getById=ja(function(a){return o.appendChild(a).id=u,!n.getElementsByName||!n.getElementsByName(u).length}),c.getById?(d.find.ID=function(a,b){if("undefined"!=typeof b.getElementById&&p){var c=b.getElementById(a);return c?[c]:[]}},d.filter.ID=function(a){var b=a.replace(_,aa);return function(a){return a.getAttribute("id")===b}}):(delete d.find.ID,d.filter.ID=function(a){var b=a.replace(_,aa);return function(a){var c="undefined"!=typeof a.getAttributeNode&&a.getAttributeNode("id");return c&&c.value===b}}),d.find.TAG=c.getElementsByTagName?function(a,b){return"undefined"!=typeof b.getElementsByTagName?b.getElementsByTagName(a):c.qsa?b.querySelectorAll(a):void 0}:function(a,b){var c,d=[],e=0,f=b.getElementsByTagName(a);if("*"===a){while(c=f[e++])1===c.nodeType&&d.push(c);return d}return f},d.find.CLASS=c.getElementsByClassName&&function(a,b){if("undefined"!=typeof b.getElementsByClassName&&p)return b.getElementsByClassName(a)},r=[],q=[],(c.qsa=Y.test(n.querySelectorAll))&&(ja(function(a){o.appendChild(a).innerHTML="",a.querySelectorAll("[msallowcapture^='']").length&&q.push("[*^$]="+K+"*(?:''|\"\")"),a.querySelectorAll("[selected]").length||q.push("\\["+K+"*(?:value|"+J+")"),a.querySelectorAll("[id~="+u+"-]").length||q.push("~="),a.querySelectorAll(":checked").length||q.push(":checked"),a.querySelectorAll("a#"+u+"+*").length||q.push(".#.+[+~]")}),ja(function(a){a.innerHTML="";var b=n.createElement("input");b.setAttribute("type","hidden"),a.appendChild(b).setAttribute("name","D"),a.querySelectorAll("[name=d]").length&&q.push("name"+K+"*[*^$|!~]?="),2!==a.querySelectorAll(":enabled").length&&q.push(":enabled",":disabled"),o.appendChild(a).disabled=!0,2!==a.querySelectorAll(":disabled").length&&q.push(":enabled",":disabled"),a.querySelectorAll("*,:x"),q.push(",.*:")})),(c.matchesSelector=Y.test(s=o.matches||o.webkitMatchesSelector||o.mozMatchesSelector||o.oMatchesSelector||o.msMatchesSelector))&&ja(function(a){c.disconnectedMatch=s.call(a,"*"),s.call(a,"[s!='']:x"),r.push("!=",N)}),q=q.length&&new RegExp(q.join("|")),r=r.length&&new RegExp(r.join("|")),b=Y.test(o.compareDocumentPosition),t=b||Y.test(o.contains)?function(a,b){var c=9===a.nodeType?a.documentElement:a,d=b&&b.parentNode;return a===d||!(!d||1!==d.nodeType||!(c.contains?c.contains(d):a.compareDocumentPosition&&16&a.compareDocumentPosition(d)))}:function(a,b){if(b)while(b=b.parentNode)if(b===a)return!0;return!1},B=b?function(a,b){if(a===b)return l=!0,0;var d=!a.compareDocumentPosition-!b.compareDocumentPosition;return d?d:(d=(a.ownerDocument||a)===(b.ownerDocument||b)?a.compareDocumentPosition(b):1,1&d||!c.sortDetached&&b.compareDocumentPosition(a)===d?a===n||a.ownerDocument===v&&t(v,a)?-1:b===n||b.ownerDocument===v&&t(v,b)?1:k?I(k,a)-I(k,b):0:4&d?-1:1)}:function(a,b){if(a===b)return l=!0,0;var c,d=0,e=a.parentNode,f=b.parentNode,g=[a],h=[b];if(!e||!f)return a===n?-1:b===n?1:e?-1:f?1:k?I(k,a)-I(k,b):0;if(e===f)return la(a,b);c=a;while(c=c.parentNode)g.unshift(c);c=b;while(c=c.parentNode)h.unshift(c);while(g[d]===h[d])d++;return d?la(g[d],h[d]):g[d]===v?-1:h[d]===v?1:0},n):n},ga.matches=function(a,b){return ga(a,null,null,b)},ga.matchesSelector=function(a,b){if((a.ownerDocument||a)!==n&&m(a),b=b.replace(S,"='$1']"),c.matchesSelector&&p&&!A[b+" "]&&(!r||!r.test(b))&&(!q||!q.test(b)))try{var d=s.call(a,b);if(d||c.disconnectedMatch||a.document&&11!==a.document.nodeType)return d}catch(e){}return ga(b,n,null,[a]).length>0},ga.contains=function(a,b){return(a.ownerDocument||a)!==n&&m(a),t(a,b)},ga.attr=function(a,b){(a.ownerDocument||a)!==n&&m(a);var e=d.attrHandle[b.toLowerCase()],f=e&&C.call(d.attrHandle,b.toLowerCase())?e(a,b,!p):void 0;return void 0!==f?f:c.attributes||!p?a.getAttribute(b):(f=a.getAttributeNode(b))&&f.specified?f.value:null},ga.escape=function(a){return(a+"").replace(ba,ca)},ga.error=function(a){throw new Error("Syntax error, unrecognized expression: "+a)},ga.uniqueSort=function(a){var b,d=[],e=0,f=0;if(l=!c.detectDuplicates,k=!c.sortStable&&a.slice(0),a.sort(B),l){while(b=a[f++])b===a[f]&&(e=d.push(f));while(e--)a.splice(d[e],1)}return k=null,a},e=ga.getText=function(a){var b,c="",d=0,f=a.nodeType;if(f){if(1===f||9===f||11===f){if("string"==typeof a.textContent)return a.textContent;for(a=a.firstChild;a;a=a.nextSibling)c+=e(a)}else if(3===f||4===f)return a.nodeValue}else while(b=a[d++])c+=e(b);return c},d=ga.selectors={cacheLength:50,createPseudo:ia,match:V,attrHandle:{},find:{},relative:{">":{dir:"parentNode",first:!0}," ":{dir:"parentNode"},"+":{dir:"previousSibling",first:!0},"~":{dir:"previousSibling"}},preFilter:{ATTR:function(a){return a[1]=a[1].replace(_,aa),a[3]=(a[3]||a[4]||a[5]||"").replace(_,aa),"~="===a[2]&&(a[3]=" "+a[3]+" "),a.slice(0,4)},CHILD:function(a){return a[1]=a[1].toLowerCase(),"nth"===a[1].slice(0,3)?(a[3]||ga.error(a[0]),a[4]=+(a[4]?a[5]+(a[6]||1):2*("even"===a[3]||"odd"===a[3])),a[5]=+(a[7]+a[8]||"odd"===a[3])):a[3]&&ga.error(a[0]),a},PSEUDO:function(a){var b,c=!a[6]&&a[2];return V.CHILD.test(a[0])?null:(a[3]?a[2]=a[4]||a[5]||"":c&&T.test(c)&&(b=g(c,!0))&&(b=c.indexOf(")",c.length-b)-c.length)&&(a[0]=a[0].slice(0,b),a[2]=c.slice(0,b)),a.slice(0,3))}},filter:{TAG:function(a){var b=a.replace(_,aa).toLowerCase();return"*"===a?function(){return!0}:function(a){return a.nodeName&&a.nodeName.toLowerCase()===b}},CLASS:function(a){var b=y[a+" "];return b||(b=new RegExp("(^|"+K+")"+a+"("+K+"|$)"))&&y(a,function(a){return b.test("string"==typeof a.className&&a.className||"undefined"!=typeof a.getAttribute&&a.getAttribute("class")||"")})},ATTR:function(a,b,c){return function(d){var e=ga.attr(d,a);return null==e?"!="===b:!b||(e+="","="===b?e===c:"!="===b?e!==c:"^="===b?c&&0===e.indexOf(c):"*="===b?c&&e.indexOf(c)>-1:"$="===b?c&&e.slice(-c.length)===c:"~="===b?(" "+e.replace(O," ")+" ").indexOf(c)>-1:"|="===b&&(e===c||e.slice(0,c.length+1)===c+"-"))}},CHILD:function(a,b,c,d,e){var f="nth"!==a.slice(0,3),g="last"!==a.slice(-4),h="of-type"===b;return 1===d&&0===e?function(a){return!!a.parentNode}:function(b,c,i){var j,k,l,m,n,o,p=f!==g?"nextSibling":"previousSibling",q=b.parentNode,r=h&&b.nodeName.toLowerCase(),s=!i&&!h,t=!1;if(q){if(f){while(p){m=b;while(m=m[p])if(h?m.nodeName.toLowerCase()===r:1===m.nodeType)return!1;o=p="only"===a&&!o&&"nextSibling"}return!0}if(o=[g?q.firstChild:q.lastChild],g&&s){m=q,l=m[u]||(m[u]={}),k=l[m.uniqueID]||(l[m.uniqueID]={}),j=k[a]||[],n=j[0]===w&&j[1],t=n&&j[2],m=n&&q.childNodes[n];while(m=++n&&m&&m[p]||(t=n=0)||o.pop())if(1===m.nodeType&&++t&&m===b){k[a]=[w,n,t];break}}else if(s&&(m=b,l=m[u]||(m[u]={}),k=l[m.uniqueID]||(l[m.uniqueID]={}),j=k[a]||[],n=j[0]===w&&j[1],t=n),t===!1)while(m=++n&&m&&m[p]||(t=n=0)||o.pop())if((h?m.nodeName.toLowerCase()===r:1===m.nodeType)&&++t&&(s&&(l=m[u]||(m[u]={}),k=l[m.uniqueID]||(l[m.uniqueID]={}),k[a]=[w,t]),m===b))break;return t-=e,t===d||t%d===0&&t/d>=0}}},PSEUDO:function(a,b){var c,e=d.pseudos[a]||d.setFilters[a.toLowerCase()]||ga.error("unsupported pseudo: "+a);return e[u]?e(b):e.length>1?(c=[a,a,"",b],d.setFilters.hasOwnProperty(a.toLowerCase())?ia(function(a,c){var d,f=e(a,b),g=f.length;while(g--)d=I(a,f[g]),a[d]=!(c[d]=f[g])}):function(a){return e(a,0,c)}):e}},pseudos:{not:ia(function(a){var b=[],c=[],d=h(a.replace(P,"$1"));return d[u]?ia(function(a,b,c,e){var f,g=d(a,null,e,[]),h=a.length;while(h--)(f=g[h])&&(a[h]=!(b[h]=f))}):function(a,e,f){return b[0]=a,d(b,null,f,c),b[0]=null,!c.pop()}}),has:ia(function(a){return function(b){return ga(a,b).length>0}}),contains:ia(function(a){return a=a.replace(_,aa),function(b){return(b.textContent||b.innerText||e(b)).indexOf(a)>-1}}),lang:ia(function(a){return U.test(a||"")||ga.error("unsupported lang: "+a),a=a.replace(_,aa).toLowerCase(),function(b){var c;do if(c=p?b.lang:b.getAttribute("xml:lang")||b.getAttribute("lang"))return c=c.toLowerCase(),c===a||0===c.indexOf(a+"-");while((b=b.parentNode)&&1===b.nodeType);return!1}}),target:function(b){var c=a.location&&a.location.hash;return c&&c.slice(1)===b.id},root:function(a){return a===o},focus:function(a){return a===n.activeElement&&(!n.hasFocus||n.hasFocus())&&!!(a.type||a.href||~a.tabIndex)},enabled:oa(!1),disabled:oa(!0),checked:function(a){var b=a.nodeName.toLowerCase();return"input"===b&&!!a.checked||"option"===b&&!!a.selected},selected:function(a){return a.parentNode&&a.parentNode.selectedIndex,a.selected===!0},empty:function(a){for(a=a.firstChild;a;a=a.nextSibling)if(a.nodeType<6)return!1;return!0},parent:function(a){return!d.pseudos.empty(a)},header:function(a){return X.test(a.nodeName)},input:function(a){return W.test(a.nodeName)},button:function(a){var b=a.nodeName.toLowerCase();return"input"===b&&"button"===a.type||"button"===b},text:function(a){var b;return"input"===a.nodeName.toLowerCase()&&"text"===a.type&&(null==(b=a.getAttribute("type"))||"text"===b.toLowerCase())},first:pa(function(){return[0]}),last:pa(function(a,b){return[b-1]}),eq:pa(function(a,b,c){return[c<0?c+b:c]}),even:pa(function(a,b){for(var c=0;c=0;)a.push(d);return a}),gt:pa(function(a,b,c){for(var d=c<0?c+b:c;++d1?function(b,c,d){var e=a.length;while(e--)if(!a[e](b,c,d))return!1;return!0}:a[0]}function va(a,b,c){for(var d=0,e=b.length;d-1&&(f[j]=!(g[j]=l))}}else r=wa(r===g?r.splice(o,r.length):r),e?e(null,g,r,i):G.apply(g,r)})}function ya(a){for(var b,c,e,f=a.length,g=d.relative[a[0].type],h=g||d.relative[" "],i=g?1:0,k=ta(function(a){return a===b},h,!0),l=ta(function(a){return I(b,a)>-1},h,!0),m=[function(a,c,d){var e=!g&&(d||c!==j)||((b=c).nodeType?k(a,c,d):l(a,c,d));return b=null,e}];i1&&ua(m),i>1&&sa(a.slice(0,i-1).concat({value:" "===a[i-2].type?"*":""})).replace(P,"$1"),c,i0,e=a.length>0,f=function(f,g,h,i,k){var l,o,q,r=0,s="0",t=f&&[],u=[],v=j,x=f||e&&d.find.TAG("*",k),y=w+=null==v?1:Math.random()||.1,z=x.length;for(k&&(j=g===n||g||k);s!==z&&null!=(l=x[s]);s++){if(e&&l){o=0,g||l.ownerDocument===n||(m(l),h=!p);while(q=a[o++])if(q(l,g||n,h)){i.push(l);break}k&&(w=y)}c&&((l=!q&&l)&&r--,f&&t.push(l))}if(r+=s,c&&s!==r){o=0;while(q=b[o++])q(t,u,g,h);if(f){if(r>0)while(s--)t[s]||u[s]||(u[s]=E.call(i));u=wa(u)}G.apply(i,u),k&&!f&&u.length>0&&r+b.length>1&&ga.uniqueSort(i)}return k&&(w=y,j=v),t};return c?ia(f):f}return h=ga.compile=function(a,b){var c,d=[],e=[],f=A[a+" "];if(!f){b||(b=g(a)),c=b.length;while(c--)f=ya(b[c]),f[u]?d.push(f):e.push(f);f=A(a,za(e,d)),f.selector=a}return f},i=ga.select=function(a,b,e,f){var i,j,k,l,m,n="function"==typeof a&&a,o=!f&&g(a=n.selector||a);if(e=e||[],1===o.length){if(j=o[0]=o[0].slice(0),j.length>2&&"ID"===(k=j[0]).type&&c.getById&&9===b.nodeType&&p&&d.relative[j[1].type]){if(b=(d.find.ID(k.matches[0].replace(_,aa),b)||[])[0],!b)return e;n&&(b=b.parentNode),a=a.slice(j.shift().value.length)}i=V.needsContext.test(a)?0:j.length;while(i--){if(k=j[i],d.relative[l=k.type])break;if((m=d.find[l])&&(f=m(k.matches[0].replace(_,aa),$.test(j[0].type)&&qa(b.parentNode)||b))){if(j.splice(i,1),a=f.length&&sa(j),!a)return G.apply(e,f),e;break}}}return(n||h(a,o))(f,b,!p,e,!b||$.test(a)&&qa(b.parentNode)||b),e},c.sortStable=u.split("").sort(B).join("")===u,c.detectDuplicates=!!l,m(),c.sortDetached=ja(function(a){return 1&a.compareDocumentPosition(n.createElement("fieldset"))}),ja(function(a){return a.innerHTML="","#"===a.firstChild.getAttribute("href")})||ka("type|href|height|width",function(a,b,c){if(!c)return a.getAttribute(b,"type"===b.toLowerCase()?1:2)}),c.attributes&&ja(function(a){return a.innerHTML="",a.firstChild.setAttribute("value",""),""===a.firstChild.getAttribute("value")})||ka("value",function(a,b,c){if(!c&&"input"===a.nodeName.toLowerCase())return a.defaultValue}),ja(function(a){return null==a.getAttribute("disabled")})||ka(J,function(a,b,c){var d;if(!c)return a[b]===!0?b.toLowerCase():(d=a.getAttributeNode(b))&&d.specified?d.value:null}),ga}(a);r.find=x,r.expr=x.selectors,r.expr[":"]=r.expr.pseudos,r.uniqueSort=r.unique=x.uniqueSort,r.text=x.getText,r.isXMLDoc=x.isXML,r.contains=x.contains,r.escapeSelector=x.escape;var y=function(a,b,c){var d=[],e=void 0!==c;while((a=a[b])&&9!==a.nodeType)if(1===a.nodeType){if(e&&r(a).is(c))break;d.push(a)}return d},z=function(a,b){for(var c=[];a;a=a.nextSibling)1===a.nodeType&&a!==b&&c.push(a);return c},A=r.expr.match.needsContext,B=/^<([a-z][^\/\0>:\x20\t\r\n\f]*)[\x20\t\r\n\f]*\/?>(?:<\/\1>|)$/i,C=/^.[^:#\[\.,]*$/;function D(a,b,c){if(r.isFunction(b))return r.grep(a,function(a,d){return!!b.call(a,d,a)!==c});if(b.nodeType)return r.grep(a,function(a){return a===b!==c});if("string"==typeof b){if(C.test(b))return r.filter(b,a,c);b=r.filter(b,a)}return r.grep(a,function(a){return i.call(b,a)>-1!==c&&1===a.nodeType})}r.filter=function(a,b,c){var d=b[0];return c&&(a=":not("+a+")"),1===b.length&&1===d.nodeType?r.find.matchesSelector(d,a)?[d]:[]:r.find.matches(a,r.grep(b,function(a){return 1===a.nodeType}))},r.fn.extend({find:function(a){var b,c,d=this.length,e=this;if("string"!=typeof a)return this.pushStack(r(a).filter(function(){for(b=0;b1?r.uniqueSort(c):c},filter:function(a){return this.pushStack(D(this,a||[],!1))},not:function(a){return this.pushStack(D(this,a||[],!0))},is:function(a){return!!D(this,"string"==typeof a&&A.test(a)?r(a):a||[],!1).length}});var E,F=/^(?:\s*(<[\w\W]+>)[^>]*|#([\w-]+))$/,G=r.fn.init=function(a,b,c){var e,f;if(!a)return this;if(c=c||E,"string"==typeof a){if(e="<"===a[0]&&">"===a[a.length-1]&&a.length>=3?[null,a,null]:F.exec(a),!e||!e[1]&&b)return!b||b.jquery?(b||c).find(a):this.constructor(b).find(a);if(e[1]){if(b=b instanceof r?b[0]:b,r.merge(this,r.parseHTML(e[1],b&&b.nodeType?b.ownerDocument||b:d,!0)),B.test(e[1])&&r.isPlainObject(b))for(e in b)r.isFunction(this[e])?this[e](b[e]):this.attr(e,b[e]);return this}return f=d.getElementById(e[2]),f&&(this[0]=f,this.length=1),this}return a.nodeType?(this[0]=a,this.length=1,this):r.isFunction(a)?void 0!==c.ready?c.ready(a):a(r):r.makeArray(a,this)};G.prototype=r.fn,E=r(d);var H=/^(?:parents|prev(?:Until|All))/,I={children:!0,contents:!0,next:!0,prev:!0};r.fn.extend({has:function(a){var b=r(a,this),c=b.length;return this.filter(function(){for(var a=0;a-1:1===c.nodeType&&r.find.matchesSelector(c,a))){f.push(c);break}return this.pushStack(f.length>1?r.uniqueSort(f):f)},index:function(a){return a?"string"==typeof a?i.call(r(a),this[0]):i.call(this,a.jquery?a[0]:a):this[0]&&this[0].parentNode?this.first().prevAll().length:-1},add:function(a,b){return this.pushStack(r.uniqueSort(r.merge(this.get(),r(a,b))))},addBack:function(a){return this.add(null==a?this.prevObject:this.prevObject.filter(a))}});function J(a,b){while((a=a[b])&&1!==a.nodeType);return a}r.each({parent:function(a){var b=a.parentNode;return b&&11!==b.nodeType?b:null},parents:function(a){return y(a,"parentNode")},parentsUntil:function(a,b,c){return y(a,"parentNode",c)},next:function(a){return J(a,"nextSibling")},prev:function(a){return J(a,"previousSibling")},nextAll:function(a){return y(a,"nextSibling")},prevAll:function(a){return y(a,"previousSibling")},nextUntil:function(a,b,c){return y(a,"nextSibling",c)},prevUntil:function(a,b,c){return y(a,"previousSibling",c)},siblings:function(a){return z((a.parentNode||{}).firstChild,a)},children:function(a){return z(a.firstChild)},contents:function(a){return a.contentDocument||r.merge([],a.childNodes)}},function(a,b){r.fn[a]=function(c,d){var e=r.map(this,b,c);return"Until"!==a.slice(-5)&&(d=c),d&&"string"==typeof d&&(e=r.filter(d,e)),this.length>1&&(I[a]||r.uniqueSort(e),H.test(a)&&e.reverse()),this.pushStack(e)}});var K=/\S+/g;function L(a){var b={};return r.each(a.match(K)||[],function(a,c){b[c]=!0}),b}r.Callbacks=function(a){a="string"==typeof a?L(a):r.extend({},a);var b,c,d,e,f=[],g=[],h=-1,i=function(){for(e=a.once,d=b=!0;g.length;h=-1){c=g.shift();while(++h-1)f.splice(c,1),c<=h&&h--}),this},has:function(a){return a?r.inArray(a,f)>-1:f.length>0},empty:function(){return f&&(f=[]),this},disable:function(){return e=g=[],f=c="",this},disabled:function(){return!f},lock:function(){return e=g=[],c||b||(f=c=""),this},locked:function(){return!!e},fireWith:function(a,c){return e||(c=c||[],c=[a,c.slice?c.slice():c],g.push(c),b||i()),this},fire:function(){return j.fireWith(this,arguments),this},fired:function(){return!!d}};return j};function M(a){return a}function N(a){throw a}function O(a,b,c){var d;try{a&&r.isFunction(d=a.promise)?d.call(a).done(b).fail(c):a&&r.isFunction(d=a.then)?d.call(a,b,c):b.call(void 0,a)}catch(a){c.call(void 0,a)}}r.extend({Deferred:function(b){var c=[["notify","progress",r.Callbacks("memory"),r.Callbacks("memory"),2],["resolve","done",r.Callbacks("once memory"),r.Callbacks("once memory"),0,"resolved"],["reject","fail",r.Callbacks("once memory"),r.Callbacks("once memory"),1,"rejected"]],d="pending",e={state:function(){return d},always:function(){return f.done(arguments).fail(arguments),this},"catch":function(a){return e.then(null,a)},pipe:function(){var a=arguments;return r.Deferred(function(b){r.each(c,function(c,d){var e=r.isFunction(a[d[4]])&&a[d[4]];f[d[1]](function(){var a=e&&e.apply(this,arguments);a&&r.isFunction(a.promise)?a.promise().progress(b.notify).done(b.resolve).fail(b.reject):b[d[0]+"With"](this,e?[a]:arguments)})}),a=null}).promise()},then:function(b,d,e){var f=0;function g(b,c,d,e){return function(){var h=this,i=arguments,j=function(){var a,j;if(!(b=f&&(d!==N&&(h=void 0,i=[a]),c.rejectWith(h,i))}};b?k():(r.Deferred.getStackHook&&(k.stackTrace=r.Deferred.getStackHook()),a.setTimeout(k))}}return r.Deferred(function(a){c[0][3].add(g(0,a,r.isFunction(e)?e:M,a.notifyWith)),c[1][3].add(g(0,a,r.isFunction(b)?b:M)),c[2][3].add(g(0,a,r.isFunction(d)?d:N))}).promise()},promise:function(a){return null!=a?r.extend(a,e):e}},f={};return r.each(c,function(a,b){var g=b[2],h=b[5];e[b[1]]=g.add,h&&g.add(function(){d=h},c[3-a][2].disable,c[0][2].lock),g.add(b[3].fire),f[b[0]]=function(){return f[b[0]+"With"](this===f?void 0:this,arguments),this},f[b[0]+"With"]=g.fireWith}),e.promise(f),b&&b.call(f,f),f},when:function(a){var b=arguments.length,c=b,d=Array(c),e=f.call(arguments),g=r.Deferred(),h=function(a){return function(c){d[a]=this,e[a]=arguments.length>1?f.call(arguments):c,--b||g.resolveWith(d,e)}};if(b<=1&&(O(a,g.done(h(c)).resolve,g.reject),"pending"===g.state()||r.isFunction(e[c]&&e[c].then)))return g.then();while(c--)O(e[c],h(c),g.reject);return g.promise()}});var P=/^(Eval|Internal|Range|Reference|Syntax|Type|URI)Error$/;r.Deferred.exceptionHook=function(b,c){a.console&&a.console.warn&&b&&P.test(b.name)&&a.console.warn("jQuery.Deferred exception: "+b.message,b.stack,c)},r.readyException=function(b){a.setTimeout(function(){throw b})};var Q=r.Deferred();r.fn.ready=function(a){return Q.then(a)["catch"](function(a){r.readyException(a)}),this},r.extend({isReady:!1,readyWait:1,holdReady:function(a){a?r.readyWait++:r.ready(!0)},ready:function(a){(a===!0?--r.readyWait:r.isReady)||(r.isReady=!0,a!==!0&&--r.readyWait>0||Q.resolveWith(d,[r]))}}),r.ready.then=Q.then;function R(){d.removeEventListener("DOMContentLoaded",R),a.removeEventListener("load",R),r.ready()}"complete"===d.readyState||"loading"!==d.readyState&&!d.documentElement.doScroll?a.setTimeout(r.ready):(d.addEventListener("DOMContentLoaded",R),
+a.addEventListener("load",R));var S=function(a,b,c,d,e,f,g){var h=0,i=a.length,j=null==c;if("object"===r.type(c)){e=!0;for(h in c)S(a,b,h,c[h],!0,f,g)}else if(void 0!==d&&(e=!0,r.isFunction(d)||(g=!0),j&&(g?(b.call(a,d),b=null):(j=b,b=function(a,b,c){return j.call(r(a),c)})),b))for(;h1,null,!0)},removeData:function(a){return this.each(function(){W.remove(this,a)})}}),r.extend({queue:function(a,b,c){var d;if(a)return b=(b||"fx")+"queue",d=V.get(a,b),c&&(!d||r.isArray(c)?d=V.access(a,b,r.makeArray(c)):d.push(c)),d||[]},dequeue:function(a,b){b=b||"fx";var c=r.queue(a,b),d=c.length,e=c.shift(),f=r._queueHooks(a,b),g=function(){r.dequeue(a,b)};"inprogress"===e&&(e=c.shift(),d--),e&&("fx"===b&&c.unshift("inprogress"),delete f.stop,e.call(a,g,f)),!d&&f&&f.empty.fire()},_queueHooks:function(a,b){var c=b+"queueHooks";return V.get(a,c)||V.access(a,c,{empty:r.Callbacks("once memory").add(function(){V.remove(a,[b+"queue",c])})})}}),r.fn.extend({queue:function(a,b){var c=2;return"string"!=typeof a&&(b=a,a="fx",c--),arguments.length\x20\t\r\n\f]+)/i,ja=/^$|\/(?:java|ecma)script/i,ka={option:[1,""],thead:[1,"
Table 4. API Keys Related CallsTable 5. API Keys Related Calls
 
 
 
 
 
 
 
 
 
","
"],col:[2,"","
"],tr:[2,"","
"],td:[3,"","
"],_default:[0,"",""]};ka.optgroup=ka.option,ka.tbody=ka.tfoot=ka.colgroup=ka.caption=ka.thead,ka.th=ka.td;function la(a,b){var c="undefined"!=typeof a.getElementsByTagName?a.getElementsByTagName(b||"*"):"undefined"!=typeof a.querySelectorAll?a.querySelectorAll(b||"*"):[];return void 0===b||b&&r.nodeName(a,b)?r.merge([a],c):c}function ma(a,b){for(var c=0,d=a.length;c-1)e&&e.push(f);else if(j=r.contains(f.ownerDocument,f),g=la(l.appendChild(f),"script"),j&&ma(g),c){k=0;while(f=g[k++])ja.test(f.type||"")&&c.push(f)}return l}!function(){var a=d.createDocumentFragment(),b=a.appendChild(d.createElement("div")),c=d.createElement("input");c.setAttribute("type","radio"),c.setAttribute("checked","checked"),c.setAttribute("name","t"),b.appendChild(c),o.checkClone=b.cloneNode(!0).cloneNode(!0).lastChild.checked,b.innerHTML="",o.noCloneChecked=!!b.cloneNode(!0).lastChild.defaultValue}();var pa=d.documentElement,qa=/^key/,ra=/^(?:mouse|pointer|contextmenu|drag|drop)|click/,sa=/^([^.]*)(?:\.(.+)|)/;function ta(){return!0}function ua(){return!1}function va(){try{return d.activeElement}catch(a){}}function wa(a,b,c,d,e,f){var g,h;if("object"==typeof b){"string"!=typeof c&&(d=d||c,c=void 0);for(h in b)wa(a,h,c,d,b[h],f);return a}if(null==d&&null==e?(e=c,d=c=void 0):null==e&&("string"==typeof c?(e=d,d=void 0):(e=d,d=c,c=void 0)),e===!1)e=ua;else if(!e)return a;return 1===f&&(g=e,e=function(a){return r().off(a),g.apply(this,arguments)},e.guid=g.guid||(g.guid=r.guid++)),a.each(function(){r.event.add(this,b,e,d,c)})}r.event={global:{},add:function(a,b,c,d,e){var f,g,h,i,j,k,l,m,n,o,p,q=V.get(a);if(q){c.handler&&(f=c,c=f.handler,e=f.selector),e&&r.find.matchesSelector(pa,e),c.guid||(c.guid=r.guid++),(i=q.events)||(i=q.events={}),(g=q.handle)||(g=q.handle=function(b){return"undefined"!=typeof r&&r.event.triggered!==b.type?r.event.dispatch.apply(a,arguments):void 0}),b=(b||"").match(K)||[""],j=b.length;while(j--)h=sa.exec(b[j])||[],n=p=h[1],o=(h[2]||"").split(".").sort(),n&&(l=r.event.special[n]||{},n=(e?l.delegateType:l.bindType)||n,l=r.event.special[n]||{},k=r.extend({type:n,origType:p,data:d,handler:c,guid:c.guid,selector:e,needsContext:e&&r.expr.match.needsContext.test(e),namespace:o.join(".")},f),(m=i[n])||(m=i[n]=[],m.delegateCount=0,l.setup&&l.setup.call(a,d,o,g)!==!1||a.addEventListener&&a.addEventListener(n,g)),l.add&&(l.add.call(a,k),k.handler.guid||(k.handler.guid=c.guid)),e?m.splice(m.delegateCount++,0,k):m.push(k),r.event.global[n]=!0)}},remove:function(a,b,c,d,e){var f,g,h,i,j,k,l,m,n,o,p,q=V.hasData(a)&&V.get(a);if(q&&(i=q.events)){b=(b||"").match(K)||[""],j=b.length;while(j--)if(h=sa.exec(b[j])||[],n=p=h[1],o=(h[2]||"").split(".").sort(),n){l=r.event.special[n]||{},n=(d?l.delegateType:l.bindType)||n,m=i[n]||[],h=h[2]&&new RegExp("(^|\\.)"+o.join("\\.(?:.*\\.|)")+"(\\.|$)"),g=f=m.length;while(f--)k=m[f],!e&&p!==k.origType||c&&c.guid!==k.guid||h&&!h.test(k.namespace)||d&&d!==k.selector&&("**"!==d||!k.selector)||(m.splice(f,1),k.selector&&m.delegateCount--,l.remove&&l.remove.call(a,k));g&&!m.length&&(l.teardown&&l.teardown.call(a,o,q.handle)!==!1||r.removeEvent(a,n,q.handle),delete i[n])}else for(n in i)r.event.remove(a,n+b[j],c,d,!0);r.isEmptyObject(i)&&V.remove(a,"handle events")}},dispatch:function(a){var b=r.event.fix(a),c,d,e,f,g,h,i=new Array(arguments.length),j=(V.get(this,"events")||{})[b.type]||[],k=r.event.special[b.type]||{};for(i[0]=b,c=1;c-1:r.find(e,this,null,[i]).length),d[e]&&d.push(f);d.length&&g.push({elem:i,handlers:d})}return h\x20\t\r\n\f]*)[^>]*)\/>/gi,ya=/\s*$/g;function Ca(a,b){return r.nodeName(a,"table")&&r.nodeName(11!==b.nodeType?b:b.firstChild,"tr")?a.getElementsByTagName("tbody")[0]||a:a}function Da(a){return a.type=(null!==a.getAttribute("type"))+"/"+a.type,a}function Ea(a){var b=Aa.exec(a.type);return b?a.type=b[1]:a.removeAttribute("type"),a}function Fa(a,b){var c,d,e,f,g,h,i,j;if(1===b.nodeType){if(V.hasData(a)&&(f=V.access(a),g=V.set(b,f),j=f.events)){delete g.handle,g.events={};for(e in j)for(c=0,d=j[e].length;c1&&"string"==typeof q&&!o.checkClone&&za.test(q))return a.each(function(e){var f=a.eq(e);s&&(b[0]=q.call(this,e,f.html())),Ha(f,b,c,d)});if(m&&(e=oa(b,a[0].ownerDocument,!1,a,d),f=e.firstChild,1===e.childNodes.length&&(e=f),f||d)){for(h=r.map(la(e,"script"),Da),i=h.length;l")},clone:function(a,b,c){var d,e,f,g,h=a.cloneNode(!0),i=r.contains(a.ownerDocument,a);if(!(o.noCloneChecked||1!==a.nodeType&&11!==a.nodeType||r.isXMLDoc(a)))for(g=la(h),f=la(a),d=0,e=f.length;d0&&ma(g,!i&&la(a,"script")),h},cleanData:function(a){for(var b,c,d,e=r.event.special,f=0;void 0!==(c=a[f]);f++)if(T(c)){if(b=c[V.expando]){if(b.events)for(d in b.events)e[d]?r.event.remove(c,d):r.removeEvent(c,d,b.handle);c[V.expando]=void 0}c[W.expando]&&(c[W.expando]=void 0)}}}),r.fn.extend({detach:function(a){return Ia(this,a,!0)},remove:function(a){return Ia(this,a)},text:function(a){return S(this,function(a){return void 0===a?r.text(this):this.empty().each(function(){1!==this.nodeType&&11!==this.nodeType&&9!==this.nodeType||(this.textContent=a)})},null,a,arguments.length)},append:function(){return Ha(this,arguments,function(a){if(1===this.nodeType||11===this.nodeType||9===this.nodeType){var b=Ca(this,a);b.appendChild(a)}})},prepend:function(){return Ha(this,arguments,function(a){if(1===this.nodeType||11===this.nodeType||9===this.nodeType){var b=Ca(this,a);b.insertBefore(a,b.firstChild)}})},before:function(){return Ha(this,arguments,function(a){this.parentNode&&this.parentNode.insertBefore(a,this)})},after:function(){return Ha(this,arguments,function(a){this.parentNode&&this.parentNode.insertBefore(a,this.nextSibling)})},empty:function(){for(var a,b=0;null!=(a=this[b]);b++)1===a.nodeType&&(r.cleanData(la(a,!1)),a.textContent="");return this},clone:function(a,b){return a=null!=a&&a,b=null==b?a:b,this.map(function(){return r.clone(this,a,b)})},html:function(a){return S(this,function(a){var b=this[0]||{},c=0,d=this.length;if(void 0===a&&1===b.nodeType)return b.innerHTML;if("string"==typeof a&&!ya.test(a)&&!ka[(ia.exec(a)||["",""])[1].toLowerCase()]){a=r.htmlPrefilter(a);try{for(;c1)}}),r.fn.delay=function(b,c){return b=r.fx?r.fx.speeds[b]||b:b,c=c||"fx",this.queue(c,function(c,d){var e=a.setTimeout(c,b);d.stop=function(){a.clearTimeout(e)}})},function(){var a=d.createElement("input"),b=d.createElement("select"),c=b.appendChild(d.createElement("option"));a.type="checkbox",o.checkOn=""!==a.value,o.optSelected=c.selected,a=d.createElement("input"),a.value="t",a.type="radio",o.radioValue="t"===a.value}();var Xa,Ya=r.expr.attrHandle;r.fn.extend({attr:function(a,b){return S(this,r.attr,a,b,arguments.length>1)},removeAttr:function(a){return this.each(function(){r.removeAttr(this,a)})}}),r.extend({attr:function(a,b,c){var d,e,f=a.nodeType;if(3!==f&&8!==f&&2!==f)return"undefined"==typeof a.getAttribute?r.prop(a,b,c):(1===f&&r.isXMLDoc(a)||(e=r.attrHooks[b.toLowerCase()]||(r.expr.match.bool.test(b)?Xa:void 0)),void 0!==c?null===c?void r.removeAttr(a,b):e&&"set"in e&&void 0!==(d=e.set(a,c,b))?d:(a.setAttribute(b,c+""),c):e&&"get"in e&&null!==(d=e.get(a,b))?d:(d=r.find.attr(a,b),null==d?void 0:d))},attrHooks:{type:{set:function(a,b){if(!o.radioValue&&"radio"===b&&r.nodeName(a,"input")){var c=a.value;return a.setAttribute("type",b),c&&(a.value=c),b}}}},removeAttr:function(a,b){var c,d=0,e=b&&b.match(K);if(e&&1===a.nodeType)while(c=e[d++])a.removeAttribute(c)}}),Xa={set:function(a,b,c){return b===!1?r.removeAttr(a,c):a.setAttribute(c,c),c}},r.each(r.expr.match.bool.source.match(/\w+/g),function(a,b){var c=Ya[b]||r.find.attr;Ya[b]=function(a,b,d){var e,f,g=b.toLowerCase();return d||(f=Ya[g],Ya[g]=e,e=null!=c(a,b,d)?g:null,Ya[g]=f),e}});var Za=/^(?:input|select|textarea|button)$/i,$a=/^(?:a|area)$/i;r.fn.extend({prop:function(a,b){return S(this,r.prop,a,b,arguments.length>1)},removeProp:function(a){return this.each(function(){delete this[r.propFix[a]||a]})}}),r.extend({prop:function(a,b,c){var d,e,f=a.nodeType;if(3!==f&&8!==f&&2!==f)return 1===f&&r.isXMLDoc(a)||(b=r.propFix[b]||b,e=r.propHooks[b]),void 0!==c?e&&"set"in e&&void 0!==(d=e.set(a,c,b))?d:a[b]=c:e&&"get"in e&&null!==(d=e.get(a,b))?d:a[b]},propHooks:{tabIndex:{get:function(a){var b=r.find.attr(a,"tabindex");return b?parseInt(b,10):Za.test(a.nodeName)||$a.test(a.nodeName)&&a.href?0:-1}}},propFix:{"for":"htmlFor","class":"className"}}),o.optSelected||(r.propHooks.selected={get:function(a){var b=a.parentNode;return b&&b.parentNode&&b.parentNode.selectedIndex,null},set:function(a){var b=a.parentNode;b&&(b.selectedIndex,b.parentNode&&b.parentNode.selectedIndex)}}),r.each(["tabIndex","readOnly","maxLength","cellSpacing","cellPadding","rowSpan","colSpan","useMap","frameBorder","contentEditable"],function(){r.propFix[this.toLowerCase()]=this});var _a=/[\t\r\n\f]/g;function ab(a){return a.getAttribute&&a.getAttribute("class")||""}r.fn.extend({addClass:function(a){var b,c,d,e,f,g,h,i=0;if(r.isFunction(a))return this.each(function(b){r(this).addClass(a.call(this,b,ab(this)))});if("string"==typeof a&&a){b=a.match(K)||[];while(c=this[i++])if(e=ab(c),d=1===c.nodeType&&(" "+e+" ").replace(_a," ")){g=0;while(f=b[g++])d.indexOf(" "+f+" ")<0&&(d+=f+" ");h=r.trim(d),e!==h&&c.setAttribute("class",h)}}return this},removeClass:function(a){var b,c,d,e,f,g,h,i=0;if(r.isFunction(a))return this.each(function(b){r(this).removeClass(a.call(this,b,ab(this)))});if(!arguments.length)return this.attr("class","");if("string"==typeof a&&a){b=a.match(K)||[];while(c=this[i++])if(e=ab(c),d=1===c.nodeType&&(" "+e+" ").replace(_a," ")){g=0;while(f=b[g++])while(d.indexOf(" "+f+" ")>-1)d=d.replace(" "+f+" "," ");h=r.trim(d),e!==h&&c.setAttribute("class",h)}}return this},toggleClass:function(a,b){var c=typeof a;return"boolean"==typeof b&&"string"===c?b?this.addClass(a):this.removeClass(a):r.isFunction(a)?this.each(function(c){r(this).toggleClass(a.call(this,c,ab(this),b),b)}):this.each(function(){var b,d,e,f;if("string"===c){d=0,e=r(this),f=a.match(K)||[];while(b=f[d++])e.hasClass(b)?e.removeClass(b):e.addClass(b)}else void 0!==a&&"boolean"!==c||(b=ab(this),b&&V.set(this,"__className__",b),this.setAttribute&&this.setAttribute("class",b||a===!1?"":V.get(this,"__className__")||""))})},hasClass:function(a){var b,c,d=0;b=" "+a+" ";while(c=this[d++])if(1===c.nodeType&&(" "+ab(c)+" ").replace(_a," ").indexOf(b)>-1)return!0;return!1}});var bb=/\r/g,cb=/[\x20\t\r\n\f]+/g;r.fn.extend({val:function(a){var b,c,d,e=this[0];{if(arguments.length)return d=r.isFunction(a),this.each(function(c){var e;1===this.nodeType&&(e=d?a.call(this,c,r(this).val()):a,null==e?e="":"number"==typeof e?e+="":r.isArray(e)&&(e=r.map(e,function(a){return null==a?"":a+""})),b=r.valHooks[this.type]||r.valHooks[this.nodeName.toLowerCase()],b&&"set"in b&&void 0!==b.set(this,e,"value")||(this.value=e))});if(e)return b=r.valHooks[e.type]||r.valHooks[e.nodeName.toLowerCase()],b&&"get"in b&&void 0!==(c=b.get(e,"value"))?c:(c=e.value,"string"==typeof c?c.replace(bb,""):null==c?"":c)}}}),r.extend({valHooks:{option:{get:function(a){var b=r.find.attr(a,"value");return null!=b?b:r.trim(r.text(a)).replace(cb," ")}},select:{get:function(a){for(var b,c,d=a.options,e=a.selectedIndex,f="select-one"===a.type,g=f?null:[],h=f?e+1:d.length,i=e<0?h:f?e:0;i-1)&&(c=!0);return c||(a.selectedIndex=-1),f}}}}),r.each(["radio","checkbox"],function(){r.valHooks[this]={set:function(a,b){if(r.isArray(b))return a.checked=r.inArray(r(a).val(),b)>-1}},o.checkOn||(r.valHooks[this].get=function(a){return null===a.getAttribute("value")?"on":a.value})});var db=/^(?:focusinfocus|focusoutblur)$/;r.extend(r.event,{trigger:function(b,c,e,f){var g,h,i,j,k,m,n,o=[e||d],p=l.call(b,"type")?b.type:b,q=l.call(b,"namespace")?b.namespace.split("."):[];if(h=i=e=e||d,3!==e.nodeType&&8!==e.nodeType&&!db.test(p+r.event.triggered)&&(p.indexOf(".")>-1&&(q=p.split("."),p=q.shift(),q.sort()),k=p.indexOf(":")<0&&"on"+p,b=b[r.expando]?b:new r.Event(p,"object"==typeof b&&b),b.isTrigger=f?2:3,b.namespace=q.join("."),b.rnamespace=b.namespace?new RegExp("(^|\\.)"+q.join("\\.(?:.*\\.|)")+"(\\.|$)"):null,b.result=void 0,b.target||(b.target=e),c=null==c?[b]:r.makeArray(c,[b]),n=r.event.special[p]||{},f||!n.trigger||n.trigger.apply(e,c)!==!1)){if(!f&&!n.noBubble&&!r.isWindow(e)){for(j=n.delegateType||p,db.test(j+p)||(h=h.parentNode);h;h=h.parentNode)o.push(h),i=h;i===(e.ownerDocument||d)&&o.push(i.defaultView||i.parentWindow||a)}g=0;while((h=o[g++])&&!b.isPropagationStopped())b.type=g>1?j:n.bindType||p,m=(V.get(h,"events")||{})[b.type]&&V.get(h,"handle"),m&&m.apply(h,c),m=k&&h[k],m&&m.apply&&T(h)&&(b.result=m.apply(h,c),b.result===!1&&b.preventDefault());return b.type=p,f||b.isDefaultPrevented()||n._default&&n._default.apply(o.pop(),c)!==!1||!T(e)||k&&r.isFunction(e[p])&&!r.isWindow(e)&&(i=e[k],i&&(e[k]=null),r.event.triggered=p,e[p](),r.event.triggered=void 0,i&&(e[k]=i)),b.result}},simulate:function(a,b,c){var d=r.extend(new r.Event,c,{type:a,isSimulated:!0});r.event.trigger(d,null,b)}}),r.fn.extend({trigger:function(a,b){return this.each(function(){r.event.trigger(a,b,this)})},triggerHandler:function(a,b){var c=this[0];if(c)return r.event.trigger(a,b,c,!0)}}),r.each("blur focus focusin focusout resize scroll click dblclick mousedown mouseup mousemove mouseover mouseout mouseenter mouseleave change select submit keydown keypress keyup contextmenu".split(" "),function(a,b){r.fn[b]=function(a,c){return arguments.length>0?this.on(b,null,a,c):this.trigger(b)}}),r.fn.extend({hover:function(a,b){return this.mouseenter(a).mouseleave(b||a)}}),o.focusin="onfocusin"in a,o.focusin||r.each({focus:"focusin",blur:"focusout"},function(a,b){var c=function(a){r.event.simulate(b,a.target,r.event.fix(a))};r.event.special[b]={setup:function(){var d=this.ownerDocument||this,e=V.access(d,b);e||d.addEventListener(a,c,!0),V.access(d,b,(e||0)+1)},teardown:function(){var d=this.ownerDocument||this,e=V.access(d,b)-1;e?V.access(d,b,e):(d.removeEventListener(a,c,!0),V.remove(d,b))}}});var eb=/\[\]$/,fb=/\r?\n/g,gb=/^(?:submit|button|image|reset|file)$/i,hb=/^(?:input|select|textarea|keygen)/i;function ib(a,b,c,d){var e;if(r.isArray(b))r.each(b,function(b,e){c||eb.test(a)?d(a,e):ib(a+"["+("object"==typeof e&&null!=e?b:"")+"]",e,c,d)});else if(c||"object"!==r.type(b))d(a,b);else for(e in b)ib(a+"["+e+"]",b[e],c,d)}r.param=function(a,b){var c,d=[],e=function(a,b){var c=r.isFunction(b)?b():b;d[d.length]=encodeURIComponent(a)+"="+encodeURIComponent(null==c?"":c)};if(r.isArray(a)||a.jquery&&!r.isPlainObject(a))r.each(a,function(){e(this.name,this.value)});else for(c in a)ib(c,a[c],b,e);
+return d.join("&")},r.fn.extend({serialize:function(){return r.param(this.serializeArray())},serializeArray:function(){return this.map(function(){var a=r.prop(this,"elements");return a?r.makeArray(a):this}).filter(function(){var a=this.type;return this.name&&!r(this).is(":disabled")&&hb.test(this.nodeName)&&!gb.test(a)&&(this.checked||!ha.test(a))}).map(function(a,b){var c=r(this).val();return null==c?null:r.isArray(c)?r.map(c,function(a){return{name:b.name,value:a.replace(fb,"\r\n")}}):{name:b.name,value:c.replace(fb,"\r\n")}}).get()}}),r.fn.extend({wrapAll:function(a){var b;return this[0]&&(r.isFunction(a)&&(a=a.call(this[0])),b=r(a,this[0].ownerDocument).eq(0).clone(!0),this[0].parentNode&&b.insertBefore(this[0]),b.map(function(){var a=this;while(a.firstElementChild)a=a.firstElementChild;return a}).append(this)),this},wrapInner:function(a){return r.isFunction(a)?this.each(function(b){r(this).wrapInner(a.call(this,b))}):this.each(function(){var b=r(this),c=b.contents();c.length?c.wrapAll(a):b.append(a)})},wrap:function(a){var b=r.isFunction(a);return this.each(function(c){r(this).wrapAll(b?a.call(this,c):a)})},unwrap:function(a){return this.parent(a).not("body").each(function(){r(this).replaceWith(this.childNodes)}),this}}),r.expr.pseudos.hidden=function(a){return!r.expr.pseudos.visible(a)},r.expr.pseudos.visible=function(a){return!!(a.offsetWidth||a.offsetHeight||a.getClientRects().length)},o.createHTMLDocument=function(){var a=d.implementation.createHTMLDocument("").body;return a.innerHTML="
",2===a.childNodes.length}(),r.parseHTML=function(a,b,c){if("string"!=typeof a)return[];"boolean"==typeof b&&(c=b,b=!1);var e,f,g;return b||(o.createHTMLDocument?(b=d.implementation.createHTMLDocument(""),e=b.createElement("base"),e.href=d.location.href,b.head.appendChild(e)):b=d),f=B.exec(a),g=!c&&[],f?[b.createElement(f[1])]:(f=oa([a],b,g),g&&g.length&&r(g).remove(),r.merge([],f.childNodes))};function jb(a){return r.isWindow(a)?a:9===a.nodeType&&a.defaultView}r.offset={setOffset:function(a,b,c){var d,e,f,g,h,i,j,k=r.css(a,"position"),l=r(a),m={};"static"===k&&(a.style.position="relative"),h=l.offset(),f=r.css(a,"top"),i=r.css(a,"left"),j=("absolute"===k||"fixed"===k)&&(f+i).indexOf("auto")>-1,j?(d=l.position(),g=d.top,e=d.left):(g=parseFloat(f)||0,e=parseFloat(i)||0),r.isFunction(b)&&(b=b.call(a,c,r.extend({},h))),null!=b.top&&(m.top=b.top-h.top+g),null!=b.left&&(m.left=b.left-h.left+e),"using"in b?b.using.call(a,m):l.css(m)}},r.fn.extend({offset:function(a){if(arguments.length)return void 0===a?this:this.each(function(b){r.offset.setOffset(this,a,b)});var b,c,d,e,f=this[0];if(f)return f.getClientRects().length?(d=f.getBoundingClientRect(),d.width||d.height?(e=f.ownerDocument,c=jb(e),b=e.documentElement,{top:d.top+c.pageYOffset-b.clientTop,left:d.left+c.pageXOffset-b.clientLeft}):d):{top:0,left:0}},position:function(){if(this[0]){var a,b,c=this[0],d={top:0,left:0};return"fixed"===r.css(c,"position")?b=c.getBoundingClientRect():(a=this.offsetParent(),b=this.offset(),r.nodeName(a[0],"html")||(d=a.offset()),d={top:d.top+r.css(a[0],"borderTopWidth",!0),left:d.left+r.css(a[0],"borderLeftWidth",!0)}),{top:b.top-d.top-r.css(c,"marginTop",!0),left:b.left-d.left-r.css(c,"marginLeft",!0)}}},offsetParent:function(){return this.map(function(){var a=this.offsetParent;while(a&&"static"===r.css(a,"position"))a=a.offsetParent;return a||pa})}}),r.each({scrollLeft:"pageXOffset",scrollTop:"pageYOffset"},function(a,b){var c="pageYOffset"===b;r.fn[a]=function(d){return S(this,function(a,d,e){var f=jb(a);return void 0===e?f?f[b]:a[d]:void(f?f.scrollTo(c?f.pageXOffset:e,c?e:f.pageYOffset):a[d]=e)},a,d,arguments.length)}}),r.each(["top","left"],function(a,b){r.cssHooks[b]=Na(o.pixelPosition,function(a,c){if(c)return c=Ma(a,b),Ka.test(c)?r(a).position()[b]+"px":c})}),r.each({Height:"height",Width:"width"},function(a,b){r.each({padding:"inner"+a,content:b,"":"outer"+a},function(c,d){r.fn[d]=function(e,f){var g=arguments.length&&(c||"boolean"!=typeof e),h=c||(e===!0||f===!0?"margin":"border");return S(this,function(b,c,e){var f;return r.isWindow(b)?0===d.indexOf("outer")?b["inner"+a]:b.document.documentElement["client"+a]:9===b.nodeType?(f=b.documentElement,Math.max(b.body["scroll"+a],f["scroll"+a],b.body["offset"+a],f["offset"+a],f["client"+a])):void 0===e?r.css(b,c,h):r.style(b,c,e,h)},b,g?e:void 0,g)}})}),"function"==typeof define&&define.amd&&define("jquery",[],function(){return r});var kb=a.jQuery,lb=a.$;return r.noConflict=function(b){return a.$===r&&(a.$=lb),b&&a.jQuery===r&&(a.jQuery=kb),r},b||(a.jQuery=a.$=r),r});

ADDED   js-path.scm
Index: js-path.scm
==================================================================
--- /dev/null
+++ js-path.scm
@@ -0,0 +1,16 @@
+;; 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 *java-script-lib* (conc  (common:get-install-area) "/share/js/jquery-3.1.0.slim.min.js")) 

Index: key_records.scm
==================================================================
--- key_records.scm
+++ key_records.scm
@@ -10,13 +10,13 @@
 ;;======================================================================
 
 (define-inline (keys->valslots keys) ;; => ?,?,? ....
   (string-intersperse (map (lambda (x) "?") keys) ","))
 
-(define-inline (keys->key/field keys . additional)
-  (string-join (map (lambda (k)(conc k " TEXT"))
-		    (append keys additional)) ","))
+;; (define-inline (keys->key/field keys . additional)
+;;   (string-join (map (lambda (k)(conc k " TEXT"))
+;; 		    (append keys additional)) ","))
 
 (define-inline (item-list->path itemdat)
   (if (list? itemdat)
       (string-intersperse  (map cadr itemdat) "/")
       ""))

Index: keys.scm
==================================================================
--- keys.scm
+++ keys.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 .
+;;
  
 ;;======================================================================
 ;; Run keys, these are used to hierarchially organise tests and run areas
 ;;======================================================================
 
@@ -64,9 +73,13 @@
 
 ;;======================================================================
 ;; config file related routines
 ;;======================================================================
 
-(define (keys:config-get-fields confdat)
-  (let ((fields (hash-table-ref/default confdat "fields" '())))
-    (map car fields)))
+(define keys:config-get-fields common:get-fields)
+(define (keys:make-key/field-string confdat)
+  (let ((fields (configf:get-section confdat "fields")))
+    (string-join
+     (map (lambda (field)(conc (car field) " " (cadr field)))
+	  fields)
+     ",")))
 

Index: launch.scm
==================================================================
--- launch.scm
+++ launch.scm
@@ -18,16 +18,14 @@
 
 (import (prefix base64 base64:))
 (import (prefix sqlite3 sqlite3:))
 
 (declare (unit launch))
+(declare (uses subrun))
 (declare (uses common))
 (declare (uses configf))
 (declare (uses db))
-;; (declare (uses sdb))
-(declare (uses tdb))
-;; (declare (uses filedb))
 
 (include "common_records.scm")
 (include "key_records.scm")
 (include "db_records.scm")
 
@@ -61,11 +59,11 @@
 ;; return (conc status ": " comment) from the final section so that
 ;;   the comment can be set in the step record in launch.scm
 ;;
 (define (launch:load-logpro-dat run-id test-id stepname)
   (let ((cname (conc stepname ".dat")))
-    (if (file-exists? cname)
+    (if (common:file-exists? cname)
 	(let* ((dat  (read-config cname #f #f))
 	       (csvr (db:logpro-dat->csv dat stepname))
 	       (csvt (let-values (((fmt-cell fmt-record fmt-csv) (make-format ",")))
 		       (fmt-csv (map list->csv-record csvr))))
 	       (status (configf:lookup dat "final" "exit-status"))
@@ -82,20 +80,31 @@
 	#f)))
 
 (define (launch:runstep ezstep run-id test-id exit-info m tal testconfig)
   (let* ((stepname       (car ezstep))  ;; do stuff to run the step
 	 (stepinfo       (cadr ezstep))
-	 (stepparts      (string-match (regexp "^(\\{([^\\}]*)\\}\\s*|)(.*)$") stepinfo))
-	 (stepparms      (list-ref stepparts 2)) ;; for future use, {VAR=1,2,3}, run step for each 
+	;; (let ((info (cadr ezstep)))
+	;; 		   (if (proc? info) "" info)))
+	;; (stepproc       (let ((info (cadr ezstep)))
+	;; 		   (if (proc? info) info #f)))
+	 (stepparts      (string-match (regexp "^(\\{([^\\}\\{]*)\\}\\s*|)(.*)$") stepinfo))
+	 (stepparams     (list-ref stepparts 2)) ;; for future use, {VAR=1,2,3}, run step for each
+	 (paramparts     (if (string? stepparams)
+			     (map (lambda (x)(string-split x "=")) (string-split-fields "[^;]*=[^;]*" stepparams))
+			     '()))
+	 (subrun         (alist-ref "subrun" paramparts equal?))
 	 (stepcmd        (list-ref stepparts 3))
 	 (script         "") ; "#!/bin/bash\n") ;; yep, we depend on bin/bash FIXME!!!\
 	 (logpro-file    (conc stepname ".logpro"))
 	 (html-file      (conc stepname ".html"))
 	 (dat-file       (conc stepname ".dat"))
 	 (tconfig-logpro (configf:lookup testconfig "logpro" stepname))
-	 (logpro-used    (file-exists? logpro-file)))
+	 (logpro-used    (common:file-exists? logpro-file)))
 
+    (debug:print 0 *default-log-port* "stepparts: " stepparts ", stepparams: " stepparams
+                 ", paramparts: " paramparts ", subrun: " subrun ", stepcmd: " stepcmd)
+    
     (if (and tconfig-logpro
 	     (not logpro-used)) ;; no logpro file found but have a defn in the testconfig
 	(begin
 	  (with-output-to-file logpro-file
 	    (lambda ()
@@ -104,16 +113,16 @@
 	      (print tconfig-logpro)))
 	  (set! logpro-used #t)))
     
     ;; NB// can safely assume we are in test-area directory
     (debug:print 4 *default-log-port* "ezsteps:\n stepname: " stepname " stepinfo: " stepinfo " stepparts: " stepparts
-		 " stepparms: " stepparms " stepcmd: " stepcmd)
+		 " stepparams: " stepparams " stepcmd: " stepcmd)
     
     ;; ;; first source the previous environment
     ;; (let ((prev-env (conc ".ezsteps/" prevstep (if (string-search (regexp "csh") 
     ;;      							 (get-environment-variable "SHELL")) ".csh" ".sh"))))
-    ;;   (if (and prevstep (file-exists? prev-env))
+    ;;   (if (and prevstep (common:file-exists? prev-env))
     ;;       (set! script (conc script "source " prev-env))))
     
     ;; call the command using mt_ezstep
     ;; (set! script (conc "mt_ezstep " stepname " " (if prevstep prevstep "x") " " stepcmd))
     
@@ -122,17 +131,24 @@
     ;; now launch the actual process
     (call-with-environment-variables 
      (list (cons "PATH" (conc (get-environment-variable "PATH") ":.")))
      (lambda () ;; (process-run "/bin/bash" "-c" "exec ls -l /tmp/foobar > /tmp/delme-more.log 2>&1")
        (let* ((cmd (conc stepcmd " > " stepname ".log 2>&1")) ;; >outfile 2>&1 
-	      (pid (process-run "/bin/bash" (list "-c" cmd))))
-
+	      (pid #f))
+	 (let ((proc (lambda ()
+		       (set! pid (process-run "/bin/bash" (list "-c" cmd))))))
+	   (if subrun
+               (begin
+                 (debug:print-info 0 *default-log-port* "Running without MT_.* environment variables.")
+                 (common:without-vars proc "^MT_.*"))
+	       (proc)))
+	 
          (with-output-to-file "Makefile.ezsteps"
            (lambda ()
              (print stepname ".log :")
              (print "\t" cmd)
-             (if (file-exists? (conc stepname ".logpro"))
+             (if (common:file-exists? (conc stepname ".logpro"))
                  (print "\tlogpro " stepname ".logpro " stepname ".html < " stepname ".log"))
              (print)
              (print stepname " : " stepname ".log")
              (print))
            #:append)
@@ -172,11 +188,11 @@
 	  (logfna (if logpro-used (conc stepname ".html") ""))
 	  (comment #f))
       (if logpro-used
 	  (let ((datfile (conc stepname ".dat")))
 	    ;; load the .dat file into the test_data table if it exists
-	    (if (file-exists? datfile)
+	    (if (common:file-exists? datfile)
 		(set! comment (launch:load-logpro-dat run-id test-id stepname)))
 	    (rmt:test-set-log! run-id test-id (conc stepname ".html"))))
       (rmt:teststep-set-status! run-id test-id stepname "end" exinfo comment logfna))
     ;; set the test final status
     (let* ((process-exit-status (launch:einf-exit-code exit-info)) ;; (vector-ref exit-info 2))
@@ -243,11 +259,11 @@
 	 (launch:einf-rollup-status-set! exit-info 1) ;; (vector-set! exit-info 3 1) ;; force fail, this used to be next-state but that doesn't make sense. should always be "COMPLETED" 
 	 (tests:test-set-status! run-id test-id "COMPLETED" "FAIL" (conc "Failed at step " stepname) #f)
 	 )))
     logpro-used))
 
-(define (launch:manage-steps run-id test-id item-path fullrunscript ezsteps test-name tconfigreg exit-info m)
+(define (launch:manage-steps run-id test-id item-path fullrunscript ezsteps subrun test-name tconfigreg exit-info m)
   ;; (let-values
   ;;  (((pid exit-status exit-code)
   ;;    (run-n-wait fullrunscript)))
   ;; (tests:test-set-status! test-id "RUNNING" "n/a" #f #f)
   ;; Since we should have a clean slate at this time there is no need to do 
@@ -277,12 +293,13 @@
 		 (thread-sleep! 2)
 		 (loop (+ i 1)))
 	       )))))
   ;; then, if runscript ran ok (or did not get called)
   ;; do all the ezsteps (if any)
-  (if ezsteps
-      (let* ((testconfig ;; (read-config (conc work-area "/testconfig") #f #t environ-patt: "pre-launch-env-vars")) ;; FIXME??? is allow-system ok here?
+  (if (or ezsteps subrun)
+      (let* ((test-run-dir (tests:get-test-path-from-environment))
+             (testconfig ;; (read-config (conc work-area "/testconfig") #f #t environ-patt: "pre-launch-env-vars")) ;; FIXME??? is allow-system ok here?
 	      ;; NOTE: it is tempting to turn off force-create of testconfig but dynamic
 	      ;;       ezstep names need a full re-eval here.
 	      (tests:get-testconfig test-name item-path tconfigreg #t force-create: #t)) ;; 'return-procs)))
 	     (ezstepslst (if (hash-table? testconfig)
 			     (hash-table-ref/default testconfig "ezsteps" '())
@@ -296,32 +313,55 @@
 	;; after all that, still no testconfig? Time to abort
 	(if (not testconfig)
 	    (begin
 	      (debug:print-error 0 *default-log-port* "Failed to resolve megatest.config, runconfigs.config and testconfig issues. Giving up now")
 	      (exit 1)))
-	(if (not (file-exists? ".ezsteps"))(create-directory ".ezsteps"))
-	;; if ezsteps was defined then we are sure to have at least one step but check anyway
-	(if (not (> (length ezstepslst) 0))
-	    (debug:print-error 0 *default-log-port* "ezsteps defined but ezstepslst is zero length")
-	    (let loop ((ezstep (car ezstepslst))
-		       (tal    (cdr ezstepslst))
-		       (prevstep #f))
-	      ;; check exit-info (vector-ref exit-info 1)
-	      (if (launch:einf-exit-status exit-info) ;; (vector-ref exit-info 1)
-		  (let ((logpro-used (launch:runstep ezstep run-id test-id exit-info m tal testconfig))
-			(stepname    (car ezstep)))
-		    ;; if logpro-used read in the stepname.dat file
-		    (if (and logpro-used (file-exists? (conc stepname ".dat")))
-			(launch:load-logpro-dat run-id test-id stepname))
-		    (if (steprun-good? logpro-used (launch:einf-exit-code exit-info))
-			(if (not (null? tal))
-			    (loop (car tal) (cdr tal) stepname))
-			(debug:print 4 *default-log-port* "WARNING: step " (car ezstep) " failed. Stopping")))
-		  (debug:print 4 *default-log-port* "WARNING: a prior step failed, stopping at " ezstep)))))))
+
+	;; create a proc for the subrun if requested, save that proc in the ezsteps table as the last entry
+	;; 1. get section [runarun]
+	;; 2. unset MT_* vars
+	;; 3. fix target
+	;; 4. fix runname
+	;; 5. fix testpatt or calculate it from contour
+	;; 6. launch the run
+	;; 7. roll up the run result and or roll up the logpro processed result
+	(when (configf:lookup testconfig "subrun" "runwait") ;; we use runwait as the flag that a subrun is requested
+            (subrun:initialize-toprun-test testconfig test-run-dir)
+	    (let* ((mt-cmd (subrun:launch-cmd test-run-dir)))
+              (debug:print-info 0 *default-log-port* "Subrun command is \"" mt-cmd "\"")
+              (set! ezsteps #t) ;; set the needed flag
+	      (set! ezstepslst
+                    (append (or ezstepslst '())
+                            (list (list "subrun" (conc "{subrun=true} " mt-cmd)))))))
+
+	;; process the ezsteps
+	(if ezsteps
+	    (begin
+	      (if (not (common:file-exists? ".ezsteps"))(create-directory ".ezsteps"))
+	      ;; if ezsteps was defined then we are sure to have at least one step but check anyway
+	      (if (not (> (length ezstepslst) 0))
+		  (debug:print-error 0 *default-log-port* "ezsteps defined but ezstepslst is zero length")
+		  (let loop ((ezstep (car ezstepslst))
+			     (tal    (cdr ezstepslst))
+			     (prevstep #f))
+                    (debug:print-info 0 *default-log-port* "Processing ezstep \"" (string-intersperse ezstep " ") "\"")
+		    ;; check exit-info (vector-ref exit-info 1)
+		    (if (launch:einf-exit-status exit-info) ;; (vector-ref exit-info 1)
+			(let ((logpro-used (launch:runstep ezstep run-id test-id exit-info m tal testconfig))
+			      (stepname    (car ezstep)))
+			  ;; if logpro-used read in the stepname.dat file
+			  (if (and logpro-used (common:file-exists? (conc stepname ".dat")))
+			      (launch:load-logpro-dat run-id test-id stepname))
+			  (if (steprun-good? logpro-used (launch:einf-exit-code exit-info))
+			      (if (not (null? tal))
+				  (loop (car tal) (cdr tal) stepname))
+			      (debug:print 0 *default-log-port* "WARNING: step " (car ezstep) " failed. Stopping")))
+			(debug:print 0 *default-log-port* "WARNING: a prior step failed, stopping at " ezstep)))))))))
 
 (define (launch:monitor-job run-id test-id item-path fullrunscript ezsteps test-name tconfigreg exit-info m work-area runtlim misc-flags)
-  (let* ((start-seconds (current-seconds))
+  (let* ((update-period (string->number (or (configf:lookup *configdat* "setup" "test-stats-update-period") "30")))
+         (start-seconds (current-seconds))
 	 (calc-minutes  (lambda ()
 			  (inexact->exact 
 			   (round 
 			    (- 
 			     (current-seconds) 
@@ -330,30 +370,38 @@
     ;; (tests:set-full-meta-info #f test-id run-id (calc-minutes) work-area)
     ;; (tests:set-full-meta-info test-id run-id (calc-minutes) work-area)
     (tests:set-full-meta-info #f test-id run-id (calc-minutes) work-area 10)
     (let loop ((minutes   (calc-minutes))
 	       (cpu-load  (alist-ref 'adj-core-load (common:get-normalized-cpu-load #f)))
-	       (disk-free (get-df (current-directory))))
-      (let ((new-cpu-load (let* ((load  (alist-ref 'adj-core-load (common:get-normalized-cpu-load #f)))
-				 (delta (abs (- load cpu-load))))
-			    (if (> delta 0.1) ;; don't bother updating with small changes
-				load
-				#f)))
-	    (new-disk-free (let* ((df    (get-df (current-directory)))
-				  (delta (abs (- df disk-free))))
-			     (if (> delta 200) ;; ignore changes under 200 Meg
-				 df
-				 #f))))
+	       (disk-free (get-df (current-directory)))
+               (last-sync (current-seconds)))
+      (let* ((over-time     (> (current-seconds) (+ last-sync update-period)))
+             (new-cpu-load  (let* ((load  (alist-ref 'adj-core-load (common:get-normalized-cpu-load #f)))
+                                   (delta (abs (- load cpu-load))))
+                              (if (> delta 0.1) ;; don't bother updating with small changes
+                                  load
+                                  #f)))
+             (new-disk-free (let* ((df    (if over-time ;; only get df every 30 seconds
+                                              (get-df (current-directory))
+                                              disk-free))
+                                   (delta (abs (- df disk-free))))
+                              (if (and (> df 0)
+                                       (> (/ delta df) 0.1)) ;; (> delta 200) ;; ignore changes under 200 Meg
+                                  df
+                                  #f)))
+             (do-sync       (or new-cpu-load new-disk-free over-time)))
+        (debug:print 4 *default-log-port* "cpu: " new-cpu-load " disk: " new-disk-free " last-sync: " last-sync " do-sync: " do-sync)
 	(set! kill-job? (or (test-get-kill-request run-id test-id) ;; run-id test-name itemdat))
 			    (and runtlim (let* ((run-seconds   (- (current-seconds) start-seconds))
 						(time-exceeded (> run-seconds runtlim)))
 					   (if time-exceeded
 					       (begin
 						 (debug:print-info 0 *default-log-port* "KILLING TEST DUE TO TIME LIMIT EXCEEDED! Runtime=" run-seconds " seconds, limit=" runtlim)
 						 #t)
 					       #f)))))
-	(tests:update-central-meta-info run-id test-id new-cpu-load new-disk-free (calc-minutes) #f #f)
+        (if do-sync
+            (tests:update-central-meta-info run-id test-id new-cpu-load new-disk-free (calc-minutes) #f #f))
 	(if kill-job? 
 	    (begin
 	      (mutex-lock! m)
 	      ;; NOTE: The pid can change as different steps are run. Do we need handshaking between this
 	      ;;       section and the runit section? Or add a loop that tries three times with a 1/4 second
@@ -397,11 +445,14 @@
 	      (exit)))
 	(if (hash-table-ref/default misc-flags 'keep-going #f)
 	    (begin
 	      (thread-sleep! 3) ;; (+ 3 (random 6))) ;; add some jitter to the call home time to spread out the db accesses
 	      (if (hash-table-ref/default misc-flags 'keep-going #f)  ;; keep originals for cpu-load and disk-free unless they change more than the allowed delta
-		  (loop (calc-minutes) (or new-cpu-load cpu-load) (or new-disk-free disk-free)))))))
+		  (loop (calc-minutes)
+                        (or new-cpu-load cpu-load)
+                        (or new-disk-free disk-free)
+                        (if do-sync (current-seconds) last-sync)))))))
     (tests:update-central-meta-info run-id test-id (get-cpu-load) (get-df (current-directory))(calc-minutes) #f #f))) ;; NOTE: Checking twice for keep-going is intentional
 
 
 (define (launch:execute encoded-cmd)
   (let* ((cmdinfo    (common:read-encoded-string encoded-cmd))
@@ -414,10 +465,11 @@
 	       (top-path  (assoc/default 'toppath   cmdinfo))
 	       (work-area (assoc/default 'work-area cmdinfo))  ;; work-area is the test run area
 	       (test-name (assoc/default 'test-name cmdinfo))
 	       (runscript (assoc/default 'runscript cmdinfo))
 	       (ezsteps   (assoc/default 'ezsteps   cmdinfo))
+	       (subrun    (assoc/default 'subrun    cmdinfo))
 	       ;; (runremote (assoc/default 'runremote cmdinfo))
 	       ;; (transport (assoc/default 'transport cmdinfo))  ;; not used
 	       ;; (serverinf (assoc/default 'serverinf cmdinfo))
 	       ;; (port      (assoc/default 'port      cmdinfo))
 	       (serverurl (assoc/default 'serverurl cmdinfo))
@@ -439,85 +491,78 @@
 	       (keyvals   #f)
 	       (fullrunscript (if (not runscript)
                                   #f
                                   (if (substring-index "/" runscript)
                                       runscript ;; use unadultered if contains slashes
-                                      (let ((fulln (conc testpath "/" runscript)))
-	                                  (if (and (file-exists? fulln)
+                                      (let ((fulln (conc work-area "/" runscript)))
+	                                  (if (and (common:file-exists? fulln)
                                                    (file-execute-access? fulln))
                                               fulln
                                               runscript))))) ;; assume it is on the path
-	       ) ;; (rollup-status 0)
+               (check-work-area           (lambda ()
+                                            ;; NFS might not have propagated the directory meta data to the run host - give it time if needed
+                                            (let loop ((count 0))
+                                              (if (or (common:directory-exists? work-area)
+                                                      (> count 10))
+                                                  (change-directory work-area)
+                                                  (begin
+                                                    (debug:print 0 *default-log-port* "INFO: Not starting job yet - directory " work-area " not found")
+                                                    (thread-sleep! 10)
+                                                    (loop (+ count 1)))))
+
+                                            (if (not (string=?  (common:real-path work-area)(common:real-path (current-directory))))
+                                                (begin
+                                                  (debug:print 0 *default-log-port*
+                                                               "INFO: we are expecting to be in directory " work-area "\n"
+                                                               "     but we are actually in the directory " (current-directory) "\n"
+                                                               "     doing another change dir.")
+                                                  (change-directory work-area)))
+                                            
+                                            ;; spot check that the files in testpath are available. Too often NFS delays cause problems here.
+                                            (let ((files      (glob (conc testpath "/*")))
+                                                  (bad-files '()))
+                                              (for-each
+                                               (lambda (fullname)
+                                                 (let* ((fname (pathname-strip-directory fullname))
+                                                        (targn (conc work-area "/" fname)))
+                                                   (if (not (file-exists? targn))
+                                                       (set! bad-files (cons fname bad-files)))))
+                                               files)
+                                              (if (not (null? bad-files))
+                                                  (begin
+                                                    (debug:print 0 *default-log-port* "INFO: test data from " testpath " not copied properly or filesystem problems causing data to not be found. Re-running the copy command.")
+                                                    (debug:print 0 *default-log-port* "INFO: missing files from " work-area ": " (string-intersperse bad-files ", "))
+                                                    (launch:test-copy testpath work-area))))
+                                            ;; one more time, change to the work-area directory
+                                            (change-directory work-area)))
+	       ) ;; let*
+
+	  (if contour (setenv "MT_CONTOUR" contour))
+	  
+	  ;; immediated set some key variables from CMDINFO data, yes, these will be set again below ...
+	  ;;
+	  (setenv "MT_TESTSUITENAME" areaname)
+	  (setenv "MT_RUN_AREA_HOME" top-path)
+	  (set! *toppath* top-path)
+          (change-directory *toppath*) ;; temporarily switch to the run area home
+	  (setenv "MT_TEST_RUN_DIR"  work-area)
+
+	  (launch:setup) ;; should be properly in the run area home now
 
 	  (if contour (setenv "MT_CONTOUR" contour))
 	  
 	  ;; immediated set some key variables from CMDINFO data, yes, these will be set again below ...
 	  ;;
 	  (setenv "MT_TESTSUITENAME" areaname)
 	  (setenv "MT_RUN_AREA_HOME" top-path)
 	  (set! *toppath* top-path)
+          (change-directory *toppath*) ;; temporarily switch to the run area home
 	  (setenv "MT_TEST_RUN_DIR"  work-area)
 
-	  ;; On NFS it can be slow and unreliable to get needed startup information.
-	  ;;  i. Check if we are on the homehost, if so, proceed
-	  ;; ii. Check if host and port passed in via CMDINFO are valid and if
-	  ;;     possible use them.
-	  (let ((bestadrs (server:get-best-guess-address (get-host-name)))
-		(needcare #f))
-	    (if (equal? homehost bestadrs) ;; we are likely on the homehost
-		(debug:print-info 0 *default-log-port* "test " test-name " appears to be running on the homehost " homehost)
-		(let ((host-port (if serverurl (string-split serverurl ":") #f)))
-		  (if (not *runremote*)(set! *runremote* (make-remote))) ;; init *runremote*
-		  (if (string? homehost)
-		      (if (and host-port
-			       (> (length host-port) 1))
-			  (let* ((host      (car host-port))
-                                 (port      (cadr host-port))
-                                 (start-res (http-transport:client-connect host port))
-                                 (ping-res  (rmt:login-no-auto-client-setup start-res)))
-			    (if (and start-res
-				     ping-res)
-				;; (begin ;; let ((url  (http-transport:server-dat-make-url start-res)))
-				(begin
-				  (remote-conndat-set! *runremote* start-res)
-				  ;; (remote-server-url-set! *runremote* url)
-				  ;; (if (server:ping url)
-				  (debug:print-info 0 *default-log-port* "connected to " host ":" port " using CMDINFO data."))
-				(begin
-				  (debug:print-info 0 *default-log-port* "have CMDINFO data but failed to connect to " host ":" port)
-				  (set! *runremote* #f))
-				  ;; (remote-conndat-set! *runremote* #f))
-				))
-			  (begin
-			    (set! *runremote* #f)
-			    (debug:print-info 0 *default-log-port* (if host-port
-								       (conc "received invalid host-port information " host-port)
-								       "no host-port information received"))
-			    ;; potential for bad situation if simultaneous starting of hundreds of jobs on servers, set needcare.
-			    (set! needcare #t)))
-		      (begin
-			(set! *runremote* #f)
-			(debug:print-info 0 *default-log-port* "received no homehost information. Please report this to support as it should not happen.")
-			(set! needcare #t)))))
-	    (if needcare  ;; due to very slow NFS we will do a brute force mkdir to ensure that the directory inode it truly available on this host
-		(let ((logdir (conc top-path "/logs"))) ;; we'll try to create this directory
-		  (handle-exceptions
-		      exn
-		      (debug:print 0 *default-log-port* "Failed to create directory " logdir " expect problems, message: " ((condition-property-accessor 'exn 'message) exn))
-		    (create-directory logdir #t)))))
-		  
-	  ;; NFS might not have propagated the directory meta data to the run host - give it time if needed
-	  (let loop ((count 0))
-	    (if (or (file-exists? top-path)
-		    (> count 10))
-		(change-directory top-path)
-		(begin
-		  (debug:print 0 *default-log-port* "INFO: Not starting job yet - directory " top-path " not found")
-		  (thread-sleep! 10)
-		  (loop (+ count 1)))))
-	  (launch:setup) ;; should be properly in the top-path now
-	  (set! tconfigreg (tests:get-all))
+	  (launch:setup) ;; should be properly in the run area home now
+          
+	  (set! tconfigreg (tests:get-all)) ;; mapping of testname => test source path
 	  (let ((sighand (lambda (signum)
 			   ;; (signal-mask! signum) ;; to mask or not? seems to cause issues in exiting
 			   (if (eq? signum signal/stop)
 			       (debug:print-error 0 *default-log-port* "attempt to STOP process. Exiting."))
 			   (set! *time-to-exit* #t)
@@ -540,14 +585,19 @@
 	  
 	  ;; Do not run the test if it is REMOVING, RUNNING, KILLREQ or REMOTEHOSTSTART,
 	  ;; Mark the test as REMOTEHOSTSTART *IMMEDIATELY*
 	  ;;
 	  (let* ((test-info (rmt:get-test-info-by-id run-id test-id))
-		 (test-host (db:test-get-host        test-info))
+		 (test-host (if test-info
+				(db:test-get-host        test-info)
+				(begin
+				  (debug:print 0 *default-log-port* "ERROR: failed to find a record for test-id " test-id ", exiting.")
+				  (exit))))
 		 (test-pid  (db:test-get-process_id  test-info)))
 	    (cond
-	     ((member (db:test-get-state test-info) '("INCOMPLETE" "KILLED" "UNKNOWN" "KILLREQ" "STUCK")) ;; prior run of this test didn't complete, go ahead and try to rerun
+             ;; -mrw- I'm removing KILLREQ from this list so that a test in KILLREQ state is treated as a "do not run" flag.
+	     ((member (db:test-get-state test-info) '("INCOMPLETE" "KILLED" "UNKNOWN" "STUCK")) ;; prior run of this test didn't complete, go ahead and try to rerun
 	      (debug:print 0 *default-log-port* "INFO: test is INCOMPLETE or KILLED, treat this execute call as a rerun request")
 	      ;; (tests:test-force-state-status! run-id test-id "REMOTEHOSTSTART" "n/a")
 	      (rmt:test-set-state-status run-id test-id "REMOTEHOSTSTART" "n/a" #f)
 	      ) ;; prime it for running
 	     ((member (db:test-get-state test-info) '("RUNNING" "REMOTEHOSTSTART"))
@@ -566,16 +616,20 @@
 	  
 	  (debug:print 2 *default-log-port* "Exectuing " test-name " (id: " test-id ") on " (get-host-name))
 	  (set! keys       (rmt:get-keys))
 	  ;; (runs:set-megatest-env-vars run-id inkeys: keys inkeyvals: keyvals) ;; these may be needed by the launching process
 	  ;; one of these is defunct/redundant ...
-	  (if (not (launch:setup force: #t))
+	  (if (not (launch:setup force-reread: #t))
 	      (begin
 		(debug:print 0 *default-log-port* "Failed to setup, exiting") 
 		;; (sqlite3:finalize! db)
 		;; (sqlite3:finalize! tdb)
 		(exit 1)))
+          ;; validate that the test run area is available
+          (check-work-area)
+          
+          ;; still need to go back to run area home for next couple steps
 	  (change-directory *toppath*) 
 
 	  ;; NOTE: Current order is to process runconfigs *before* setting the MT_ vars. This 
 	  ;;       seems non-ideal but could well break stuff
 	  ;;    BUG? BUG? BUG?
@@ -583,31 +637,36 @@
 	  (let ((rconfig (full-runconfigs-read)) ;; (read-config (conc  *toppath* "/runconfigs.config") #f #t sections: (list "default" target))))
 		(wconfig (read-config "waivers.config" #f #t sections: `( "default" ,target )))) ;; read the waivers config if it exists
 	    ;; (setup-env-defaults (conc *toppath* "/runconfigs.config") run-id (make-hash-table) keyvals target)
 	    ;; (set-run-config-vars run-id keyvals target) ;; (db:get-target db run-id))
 	    ;; Now have runconfigs data loaded, set environment vars
-	    (for-each (lambda (section)
-			(for-each (lambda (varval)
-				    (let ((var (car varval))
-					  (val (cadr varval)))
-				      (if (and (string? var)(string? val))
-					  (begin
-					    (setenv var (config:eval-string-in-environment val))) ;; val)
-					  (debug:print-error 0 *default-log-port* "bad variable spec, " var "=" val))))
-				  (configf:get-section rconfig section)))
-		      (list "default" target)))
+	    (for-each
+	     (lambda (section)
+	       (for-each
+		(lambda (varval)
+		  (let ((var (car varval))
+			(val (cadr varval)))
+		    (if (and (string? var)(string? val))
+			(begin
+			  (setenv var (config:eval-string-in-environment val))) ;; val)
+			(debug:print-error 0 *default-log-port* "bad variable spec, " var "=" val))))
+		(configf:get-section rconfig section)))
+	     (list "default" target)))
           ;;(bb-check-path msg: "launch:execute post block 1")
 
 	  ;; NFS might not have propagated the directory meta data to the run host - give it time if needed
 	  (let loop ((count 0))
-	    (if (or (file-exists? work-area)
+	    (if (or (common:file-exists? work-area)
 		    (> count 10))
 		(change-directory work-area)
 		(begin
 		  (debug:print 0 *default-log-port* "INFO: Not starting job yet - directory " work-area " not found")
 		  (thread-sleep! 10)
 		  (loop (+ count 1)))))
+
+          ;; now we can switch to the work-area?
+          (change-directory work-area)
           ;;(bb-check-path msg: "launch:execute post block 1.5")
 	  ;; (change-directory work-area) 
 	  (set! keyvals    (keys:target->keyval keys target))
 	  ;; apply pre-overrides before other variables. The pre-override vars must not
 	  ;; clobbers things from the official sources such as megatest.config and runconfigs.config
@@ -656,11 +715,14 @@
           ;;(bb-check-path msg: "launch:execute post block 41")
 	  (runs:set-megatest-env-vars run-id inkeys: keys inkeyvals: keyvals)
           ;;(bb-check-path msg: "launch:execute post block 42")
 	  (set-item-env-vars itemdat)
           ;;(bb-check-path msg: "launch:execute post block 43")
-	  (save-environment-as-files "megatest")
+          (let ((blacklist (configf:lookup *configdat* "setup" "blacklistvars")))
+            (if blacklist
+                (save-environment-as-files "megatest" ignorevars: (string-split blacklist))
+                (save-environment-as-files "megatest")))
           ;;(bb-check-path msg: "launch:execute post block 44")
 	  ;; open-run-close not needed for test-set-meta-info
 	  ;; (tests:set-full-meta-info #f test-id run-id 0 work-area)
 	  ;; (tests:set-full-meta-info test-id run-id 0 work-area)
 	  (tests:set-full-meta-info #f test-id run-id 0 work-area 10)
@@ -668,18 +730,24 @@
 	  ;; (thread-sleep! 0.3) ;; NFS slowness has caused grief here
 
 	  (if (args:get-arg "-xterm")
 	      (set! fullrunscript "xterm")
 	      (if (and fullrunscript 
-		       (file-exists? fullrunscript)
+		       (common:file-exists? fullrunscript)
 		       (not (file-execute-access? fullrunscript)))
 		  (system (conc "chmod ug+x " fullrunscript))))
 
 	  ;; We are about to actually kick off the test
 	  ;; so this is a good place to remove the records for 
 	  ;; any previous runs
 	  ;; (db:test-remove-steps db run-id testname itemdat)
+	  ;; now is also a good time to write the .testconfig file
+	  (let* ((tconfig-fname   (conc work-area "/.testconfig"))
+		 (tconfig-tmpfile (conc tconfig-fname ".tmp"))
+		 (tconfig         (tests:get-testconfig test-name item-path tconfigreg #t force-create: #t))) ;; 'return-procs)))
+	    (configf:write-alist tconfig tconfig-tmpfile)
+	    (file-move tconfig-tmpfile tconfig-fname #t))
 	  ;; 
 	  (let* ((m            (make-mutex))
 		 (kill-job?    #f)
 		 (exit-info    (make-launch:einf pid: #t exit-status: #t exit-code: #t rollup-status: 0)) ;; pid exit-status exit-code (i.e. process was successfully run) rollup-status
 		 (job-thread   #f)
@@ -686,11 +754,11 @@
 		 ;; (keep-going   #t)
 		 (misc-flags   (let ((ht (make-hash-table)))
 				 (hash-table-set! ht 'keep-going #t)
 				 ht))
 		 (runit        (lambda ()
-				 (launch:manage-steps run-id test-id item-path fullrunscript ezsteps test-name tconfigreg exit-info m)))
+				 (launch:manage-steps run-id test-id item-path fullrunscript ezsteps subrun test-name tconfigreg exit-info m)))
 		 (monitorjob   (lambda ()
 				 (launch:monitor-job  run-id test-id item-path fullrunscript ezsteps test-name tconfigreg exit-info m work-area runtlim misc-flags)))
 		 (th1          (make-thread monitorjob "monitor job"))
 		 (th2          (make-thread runit "run job")))
 	    (set! job-thread th2)
@@ -741,12 +809,15 @@
 	      (rmt:update-run-stats run-id (rmt:get-raw-run-stats run-id)))
 	    (mutex-unlock! m)
 	    (debug:print 2 *default-log-port* "Output from running " fullrunscript ", pid " (launch:einf-pid exit-info) " in work area " 
 			 work-area ":\n====\n exit code " (launch:einf-exit-code exit-info) "\n" "====\n")
 	    (if (not (launch:einf-exit-status exit-info))
-		(exit 4)))))))
+		(exit 4))))
+        )))
 
+;; DO NOT USE - caching of configs is handled in launch:setup now.
+;;
 (define (launch:cache-config)
   ;; if we have a linktree and -runtests and -target and the directory exists dump the config
   ;; to megatest-(current-seconds).cfg and symlink it to megatest.cfg
   (if (and *configdat* 
 	   (or (args:get-arg "-run")
@@ -758,22 +829,22 @@
 			   (args:get-arg ":runname")
 			   (getenv "MT_RUNNAME")))
 	     (fulldir  (conc linktree "/"
 			     target "/"
 			     runname)))
-	(if (and linktree (file-exists? linktree)) ;; can't proceed without linktree
+	(if (and linktree (common:file-exists? linktree)) ;; can't proceed without linktree
 	    (begin
 	      (debug:print-info 0 *default-log-port* "Have -run with target=" target ", runname=" runname ", fulldir=" fulldir ", testpatt=" (or (args:get-arg "-testpatt") "%"))
-	      (if (not (file-exists? fulldir))
+	      (if (not (common:file-exists? fulldir))
 		  (create-directory fulldir #t)) ;; need to protect with exception handler 
 	      (if (and target
 		       runname
-		       (file-exists? fulldir))
+		       (common:file-exists? fulldir))
 		  (let ((tmpfile  (conc fulldir "/.megatest.cfg." (current-seconds)))
 			(targfile (conc fulldir "/.megatest.cfg-"  megatest-version "-" megatest-fossil-hash))
 			(rconfig  (conc fulldir "/.runconfig." megatest-version "-" megatest-fossil-hash)))
-		    (if (file-exists? rconfig) ;; only cache megatest.config AFTER runconfigs has been cached
+		    (if (common:file-exists? rconfig) ;; only cache megatest.config AFTER runconfigs has been cached
 			(begin
 			  (debug:print-info 0 *default-log-port* "Caching megatest.config in " tmpfile)
                           (if (not (common:in-running-test?))
                               (configf:write-alist *configdat* tmpfile))
 			  (system (conc "ln -sf " tmpfile " " targfile))))
@@ -794,61 +865,92 @@
 ;;   side effects:
 ;;     sets; *configdat*    (megatest.config info)
 ;;           *runconfigdat* (runconfigs.config info)
 ;;           *configstatus* (status of the read data)
 ;;
-(define (launch:setup #!key (force #f) (areapath #f))
+(define (launch:setup #!key (force-reread #f) (areapath #f))
   (mutex-lock! *launch-setup-mutex*)
   (if (and *toppath*
-	   (eq? *configstatus* 'fulldata)) ;; got it all
+	   (eq? *configstatus* 'fulldata) (not force-reread)) ;; got it all
       (begin
-	(debug:print 0 *default-log-port* "NOTE: skipping launch:setup-body call since we have fulldata")
+	(debug:print 2 *default-log-port* "NOTE: skipping launch:setup-body call since we have fulldata")
 	(mutex-unlock! *launch-setup-mutex*)
 	*toppath*)
-      (let ((res (launch:setup-body force: force areapath: areapath)))
+      (let ((res (launch:setup-body force-reread: force-reread areapath: areapath)))
 	(mutex-unlock! *launch-setup-mutex*)
 	res)))
+
+;; return paths depending on what info is available.
+;;
+(define (launch:get-cache-file-paths areapath toppath target mtconfig)
+  (let* ((use-cache (common:use-cache?))
+         (runname  (common:args-get-runname))
+         (linktree (common:get-linktree))
+         (testname (common:get-full-test-name))
+         (rundir   (if (and runname target linktree)
+                       (common:directory-writable? (conc linktree "/" target "/" runname))
+                       #f))
+         (testdir  (if (and rundir testname)
+                       (common:directory-writable? (conc rundir "/" testname))
+                       #f))
+         (cachedir (or testdir rundir))
+         (mtcachef (and cachedir (conc cachedir "/" ".megatest.cfg-"  megatest-version "-" megatest-fossil-hash)))
+         (rccachef (and cachedir (conc cachedir "/" ".runconfigs.cfg-"  megatest-version "-" megatest-fossil-hash))))
+    (debug:print-info 6 *default-log-port* 
+                      "runname=" runname 
+                      "\n  linktree=" linktree
+                      "\n  testname=" testname
+                      "\n  rundir=" rundir 
+                      "\n  testdir=" testdir 
+                      "\n  cachedir=" cachedir
+                      "\n  mtcachef=" mtcachef
+                      "\n  rccachef=" rccachef)
+    (cons mtcachef rccachef)))
 
 (define (launch:setup-body #!key (force-reread #f) (areapath #f))
   (if (and (eq? *configstatus* 'fulldata)
 	   *toppath*
 	   (not force-reread)) ;; no need to reprocess
       *toppath*   ;; return toppath
-      (let* ((use-cache (common:use-cache?))
+      (let* ((use-cache (common:use-cache?)) ;; BB- use-cache checks *configdat* for use-cache setting.  We do not have *configdat*.  Bootstrapping problem here.
 	     (toppath  (or *toppath* areapath (getenv "MT_RUN_AREA_HOME"))) ;; preserve toppath
-	     
-	     (runname  (common:args-get-runname))
 	     (target   (common:args-get-target))
-	     (linktree (common:get-linktree))
-	     (contour  #f) ;; NOT READY FOR THIS (args:get-arg "-contour"))
 	     (sections (if target (list "default" target) #f)) ;; for runconfigs
 	     (mtconfig (or (args:get-arg "-config") "megatest.config")) ;; allow overriding megatest.config 
-	     (rundir   (if (and runname target linktree)
-			   (conc linktree (if contour (conc "/" contour) "") "/" target "/" runname)
-			   #f))
-             
-	     (mtcachef (and rundir (conc rundir "/" ".megatest.cfg-"  megatest-version "-" megatest-fossil-hash)))
-	     (rccachef (and rundir (conc rundir "/" ".runconfigs.cfg-"  megatest-version "-" megatest-fossil-hash)))
-	     (cancreate (and rundir (common:file-exists? rundir)(file-write-access? rundir) (not (common:in-running-test?)))))
-	;; (cxt       (hash-table-ref/default *contexts* toppath #f)))
-
-	;; create our cxt for this area if it doesn't already exist
-	;; (if (not cxt)(hash-table-set! *contexts* toppath (make-cxt)))
-	
-	;; (print "runname: " runname " target: " target " mtcachef: " mtcachef " rccachef: " rccachef)
+             (cachefiles (launch:get-cache-file-paths areapath toppath target mtconfig))
+	     ;; checking for null cachefiles should not be necessary, I was seeing error car of '(), might be a chicken bug or a red herring ...
+	     (mtcachef   (if (null? cachefiles)
+			     #f
+			     (car cachefiles))) ;; (and cachedir (conc cachedir "/" ".megatest.cfg-"  megatest-version "-" megatest-fossil-hash)))
+	     (rccachef   (if (null? cachefiles)
+			     #f
+			     (cdr cachefiles)))) ;; (and cachedir (conc cachedir "/" ".runconfigs.cfg-"  megatest-version "-" megatest-fossil-hash)))
+	      ;; (cancreate (and cachedir (common:file-exists? cachedir)(file-write-access? cachedir) (not (common:in-running-test?)))))
 	(set! *toppath* toppath) ;; This is needed when we are running as a test using CMDINFO as a datasource
+        ;;(BB> "launch:setup-body -- cachefiles="cachefiles)
 	(cond
 	 ;; if mtcachef exists just read it, however we need to assume toppath is available in $MT_RUN_AREA_HOME
-	 ((and mtcachef (common:file-exists? mtcachef) (get-environment-variable "MT_RUN_AREA_HOME") use-cache)
-	  (set! *configdat*    (configf:read-alist mtcachef))
+	 ((and (not force-reread)
+	       mtcachef  rccachef
+	       use-cache
+	       (get-environment-variable "MT_RUN_AREA_HOME")
+	       (common:file-exists? mtcachef)
+	       (common:file-exists? rccachef))
+          ;;(BB> "launch:setup-body -- cond branch 1 - use-cache")
+          (set! *configdat*    (configf:read-alist mtcachef))
+          ;;(BB> "launch:setup-body -- 1 set! *configdat*="*configdat*)
 	  (set! *runconfigdat* (configf:read-alist rccachef))
 	  (set! *configinfo*   (list *configdat*  (get-environment-variable "MT_RUN_AREA_HOME")))
 	  (set! *configstatus* 'fulldata)
 	  (set! *toppath*      (get-environment-variable "MT_RUN_AREA_HOME"))
 	  *toppath*)
+	 ;; there are no existing cached configs, do full reads of the configs and cache them
 	 ;; we have all the info needed to fully process runconfigs and megatest.config
-	 (mtcachef              
+	 ((and ;; (not force-reread) ;; force-reread is irrelevant in the AND, could however OR it?
+	       mtcachef
+	       rccachef) ;; BB- why are we doing this without asking if caching is desired?
+          ;;(BB> "launch:setup-body -- cond branch 2")
 	  (let* ((first-pass    (find-and-read-config        ;; NB// sets MT_RUN_AREA_HOME as side effect
 				 mtconfig
 				 environ-patt: "env-override"
 				 given-toppath: toppath
 				 pathenvvar: "MT_RUN_AREA_HOME"))
@@ -863,11 +965,13 @@
 				   *runconfigdat* #t 
 				   sections: sections))))
 	    (set! *runconfigdat* first-rundat)
 	    (if first-pass  ;; 
 		(begin
+                  ;;(BB> "launch:setup-body -- \"first-pass\"=first-pass")
 		  (set! *configdat*  (car first-pass))
+                  ;;(BB> "launch:setup-body -- 2 set! *configdat*="*configdat*)
 		  (set! *configinfo* first-pass)
 		  (set! *toppath*    (or toppath (cadr first-pass))) ;; use the gathered data unless already have it
 		  (set! toppath      *toppath*)
 		  (if (not *toppath*)
 		      (begin
@@ -889,26 +993,45 @@
 			 (runconfigdat (begin     ;; this read of the runconfigs will see any adjustments made by re-reading megatest.config
 					 (for-each (lambda (kt)
 						     (setenv (car kt) (cadr kt)))
 						   key-vals)
 					 (read-config (conc toppath "/runconfigs.config") *runconfigdat* #t ;; consider using runconfig:read some day ...
-						      sections: sections))))
-		    (if cancreate (configf:write-alist runconfigdat rccachef))
+						      sections: sections)))
+                         (cachefiles   (launch:get-cache-file-paths areapath toppath target mtconfig))
+                         (mtcachef     (car cachefiles))
+                         (rccachef     (cdr cachefiles)))
+                    ;;  trap exception due to stale NFS handle -- Error: (open-output-file) cannot open file - Stale NFS file handle: "/p/fdk/gwa/lefkowit/mtTesting/qa/primbeqa/links/p1222/11/PDK_r1.1.1/prim/clean/pcell_testgen/.runconfigs.cfg-1.6427-7d1e789cb3f62f9cde719a4865bb51b3c17ea853" - ticket 220546342
+                    ;; TODO - consider 1) using simple-lock to bracket cache write
+                    ;;                 2) cache in hash on server, since need to do rmt: anyway to lock.
+
+		    (if rccachef
+                        (common:fail-safe
+                         (lambda ()
+                           (configf:write-alist runconfigdat rccachef))
+                         (conc "Could not write cache file - "rccachef)))
+                    (if mtcachef
+                        (common:fail-safe
+                         (lambda ()
+                           (configf:write-alist *configdat* mtcachef))
+                         (conc "Could not write cache file - "mtcachef)))
 		    (set! *runconfigdat* runconfigdat)
-		    (if cancreate (configf:write-alist *configdat* mtcachef))
-		    (if cancreate (set! *configstatus* 'fulldata))))
+		    (if (and rccachef mtcachef) (set! *configstatus* 'fulldata))))
 		;; no configs found? should not happen but let's try to recover gracefully, return an empty hash-table
 		(set! *configdat* (make-hash-table))
 		)))
+
 	 ;; else read what you can and set the flag accordingly
+	 ;; here we don't have either mtconfig or rccachef
 	 (else
+          ;;(BB> "launch:setup-body -- cond branch 3 - else")
 	  (let* ((cfgdat   (find-and-read-config 
 			    (or (args:get-arg "-config") "megatest.config")
 			    environ-patt: "env-override"
 			    given-toppath: (get-environment-variable "MT_RUN_AREA_HOME")
 			    pathenvvar: "MT_RUN_AREA_HOME")))
-	    (if cfgdat
+
+            (if (and cfgdat (list? cfgdat) (> (length cfgdat) 0) (hash-table? (car cfgdat)))
 		(let* ((toppath  (or (get-environment-variable "MT_RUN_AREA_HOME")(cadr cfgdat)))
 		       (rdat     (read-config (conc toppath  ;; convert this to use runconfig:read!
 						    "/runconfigs.config") *runconfigdat* #t sections: sections)))
 		  (set! *configinfo*   cfgdat)
 		  (set! *configdat*    (car cfgdat))
@@ -916,12 +1039,15 @@
 		  (set! *toppath*      toppath)
 		  (set! *configstatus* 'partial))
 		(begin
 		  (debug:print-error 0 *default-log-port* "No " mtconfig " file found. Giving up.")
 		  (exit 2))))))
+	;; COND ends here.
+	
 	;; additional house keeping
-	(let* ((linktree (common:get-linktree)))
+	(let* ((linktree (or (common:get-linktree)
+			     (conc *toppath* "/lt"))))
 	  (if linktree
 	      (begin
 		(if (not (common:file-exists? linktree))
 		    (begin
 		      (handle-exceptions
@@ -935,11 +1061,11 @@
 		    exn
 		    (begin
 		      (debug:print-error 0 *default-log-port* "Something went wrong when trying to create link to linktree at " *toppath*)
 		      (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)))
 		  (let ((tlink (conc *toppath* "/lt")))
-		    (if (not (file-exists? tlink))
+		    (if (not (common:file-exists? tlink))
 			(create-symbolic-link linktree tlink)))))
 	      (begin
 		(debug:print-error 0 *default-log-port* "linktree not defined in [setup] section of megatest.config")
 		)))
 	(if (and *toppath*
@@ -947,14 +1073,36 @@
 	    (begin
 	      (setenv "MT_RUN_AREA_HOME" *toppath*)
 	      (setenv "MT_TESTSUITENAME" (common:get-testsuite-name)))
 	    (begin
 	      (debug:print-error 0 *default-log-port* "failed to find the top path to your Megatest area.")
-	      ;;(exit 1)
 	      (set! *toppath* #f) ;; force it to be false so we return #f
-	      #f
-	      ))
+	      #f))
+	
+        ;; one more attempt to cache the configs for future reading
+        (let* ((cachefiles   (launch:get-cache-file-paths areapath toppath target mtconfig))
+               (mtcachef     (car cachefiles))
+               (rccachef     (cdr cachefiles)))
+
+          ;; trap exception due to stale NFS handle -- Error: (open-output-file) cannot open file - Stale NFS file handle: "...somepath.../.runconfigs.cfg-1.6427-7d1e789cb3f62f9cde719a4865bb51b3c17ea853" - ticket 220546342
+          ;; TODO - consider 1) using simple-lock to bracket cache write
+          ;;                 2) cache in hash on server, since need to do rmt: anyway to lock.
+          (if (and rccachef *runconfigdat* (not (common:file-exists? rccachef)))
+              (common:fail-safe
+               (lambda ()
+                 (configf:write-alist *runconfigdat* rccachef))
+               (conc "Could not write cache file - "rccachef))
+              )
+          (if (and mtcachef *configdat*    (not (common:file-exists? mtcachef)))
+              (common:fail-safe
+               (lambda ()
+                 (configf:write-alist *configdat* mtcachef))
+               (conc "Could not write cache file - "mtcachef))
+              )
+          (if (and rccachef mtcachef *runconfigdat* *configdat*)
+              (set! *configstatus* 'fulldata)))
+
 	;; if have -append-config then read and append here
 	(let ((cfname (args:get-arg "-append-config")))
 	  (if (and cfname
 		   (file-read-access? cfname))
 	      (read-config cfname *configdat* #t))) ;; values are added to the hash, no need to do anything special.
@@ -971,10 +1119,26 @@
 	      (cdr res)
 	      (begin
 		(if (common:low-noise-print 20 "No valid disks or no disk with enough space")
 		    (debug:print-error 0 *default-log-port* "No valid disks found in megatest.config. Please add some to your [disks] section and ensure the directory exists and has enough space!\n    You can change minspace in the [setup] section of megatest.config. Current setting is: " minspace))
 		(exit 1))))))) ;; TODO - move the exit to the calling location and return #f
+
+(define (launch:test-copy test-src-path test-path)
+  (let* ((ovrcmd (let ((cmd (config-lookup *configdat* "setup" "testcopycmd")))
+		   (if cmd
+		       ;; substitute the TEST_SRC_PATH and TEST_TARG_PATH
+		       (string-substitute "TEST_TARG_PATH" test-path
+					  (string-substitute "TEST_SRC_PATH" test-src-path cmd #t) #t)
+		       #f)))
+	 (cmd    (if ovrcmd 
+		     ovrcmd
+		     (conc "rsync -av" (if (debug:debug-mode 1) "" "q") " " test-src-path "/ " test-path "/"
+			   " >> " test-path "/mt_launch.log 2>> " test-path "/mt_launch.log")))
+	 (status (system cmd)))
+    (if (not (eq? status 0))
+	(debug:print 2 *default-log-port* "ERROR: problem with running \"" cmd "\""))))
+
 
 ;; Desired directory structure:
 ;;
 ;;   -  -  -.
 ;;                                     |
@@ -1065,11 +1229,11 @@
 	 (begin
 	   (debug:print-error 0 *default-log-port* " Failed to remove symlink " lnkpath ((condition-property-accessor 'exn 'message) exn) ", exiting")
 	   (exit 1))
 	 (delete-file lnkpath)))
 
-    (if (not (or (file-exists? lnkpath)
+    (if (not (or (common:file-exists? lnkpath)
 		 (symbolic-link? lnkpath)))
 	(handle-exceptions
 	 exn
 	 (begin
 	   (debug:print-error 0 *default-log-port* " Failed to create symlink " lnkpath ((condition-property-accessor 'exn 'message) exn) ", exiting")
@@ -1090,11 +1254,11 @@
 				   (db:test-get-rundir testinfo) ;; ) ;; )
 				   #f)))
 	  (hash-table-set! *toptest-paths* testname curr-test-path)
 	  ;; NB// Was this for the test or for the parent in an iterated test?
 	  (rmt:general-call 'test-set-rundir-shortdir run-id lnkpath 
-			    (if (file-exists? lnkpath)
+			    (if (common:file-exists? lnkpath)
 				;; (resolve-pathname lnkpath)
 				(common:nice-path lnkpath)
 				lnkpath)
 			    testname "" run-id)
 	  ;; (rmt:general-call 'test-set-rundir run-id lnkpath testname "") ;; toptest-path)
@@ -1129,30 +1293,18 @@
 	   exn
 	   (begin
 	     (debug:print-error 0 *default-log-port* " Failed to re-create link " lnktarget ((condition-property-accessor 'exn 'message) exn) ", exiting")
 	     (exit))
 	   (if (symbolic-link? lnktarget)     (delete-file lnktarget))
-	   (if (not (file-exists? lnktarget)) (create-symbolic-link test-path lnktarget)))))
+	   (if (not (common:file-exists? lnktarget)) (create-symbolic-link test-path lnktarget)))))
 
     (if (not (directory? test-path))
 	(create-directory test-path #t)) ;; this is a hack, I don't know why out of the blue this path does not exist sometimes
 
     (if (and test-src-path (directory? test-path))
 	(begin
-	  (let* ((ovrcmd (let ((cmd (config-lookup *configdat* "setup" "testcopycmd")))
-			   (if cmd
-			       ;; substitute the TEST_SRC_PATH and TEST_TARG_PATH
-			       (string-substitute "TEST_TARG_PATH" test-path
-						  (string-substitute "TEST_SRC_PATH" test-src-path cmd #t) #t)
-			       #f)))
-		 (cmd    (if ovrcmd 
-			     ovrcmd
-			     (conc "rsync -av" (if (debug:debug-mode 1) "" "q") " " test-src-path "/ " test-path "/"
-				   " >> " test-path "/mt_launch.log 2>> " test-path "/mt_launch.log")))
-		 (status (system cmd)))
-	    (if (not (eq? status 0))
-		(debug:print 2 *default-log-port* "ERROR: problem with running \"" cmd "\"")))
+	  (launch:test-copy test-src-path test-path)
 	  (list lnkpathf lnkpath ))
 	(if (and test-src-path (> remtries 0))
 	    (begin
 	      (debug:print-error 0 *default-log-port* "Failed to create work area at " test-path " with link at " lnktarget ", remaining attempts " remtries)
 	      ;; 
@@ -1166,17 +1318,31 @@
 ;;    - could be ssh to host from hosts table (update regularly with load)
 ;;    - could be netbatch
 ;;      (launch-test db (cadr status) test-conf))
 (define (launch-test test-id run-id run-info keyvals runname test-conf test-name test-path itemdat params)
   (mutex-lock! *launch-setup-mutex*) ;; setting variables and processing the testconfig is NOT thread-safe, reuse the launch-setup mutex
-  (let* ((item-path       (item-list->path itemdat))
+  (let* ( ;; (lock-key        (conc "test-" test-id))
+	;; (got-lock        (let loop ((lock        (rmt:no-sync-get-lock lock-key))
+	;; 			     (expire-time (+ (current-seconds) 15))) ;; give up on getting the lock and steal it after 15 seconds
+	;; 		    (if (car lock)
+	;; 			#t
+	;; 			(if (> (current-seconds) expire-time)
+	;; 			    (begin
+	;; 			      (debug:print-info 0 *default-log-port* "Timed out waiting for a lock to launch test " keyvals " " runname " " test-name " " test-path)
+	;; 			      (rmt:no-sync-del! lock-key) ;; destroy the lock
+	;; 			      (loop (rmt:no-sync-get-lock lock-key) expire-time)) ;; 
+	;; 			    (begin
+	;; 			      (thread-sleep! 1)
+	;; 			      (loop (rmt:no-sync-get-lock lock-key) expire-time))))))
+	 (item-path       (item-list->path itemdat))
 	 (contour         #f)) ;; NOT READY FOR THIS (args:get-arg "-contour")))
     (let loop ((delta        (- (current-seconds) *last-launch*))
-	       (launch-delay (string->number (or (configf:lookup *configdat* "setup" "launch-delay") "5"))))
+	       (launch-delay (configf:lookup-number *configdat* "setup" "launch-delay" default: 1)))
       (if (> launch-delay delta)
 	  (begin
-	    (debug:print-info 0 *default-log-port* "Delaying launch of " test-name " for " (- launch-delay delta) " seconds")
+	    (if (common:low-noise-print 1200 "test launch delay") ;; every two hours or so remind the user about launch delay.
+		(debug:print-info 0 *default-log-port* "NOTE: test launches are delayed by " launch-delay " seconds. See megatest.config launch-delay setting to adjust.")) ;; launch of " test-name " for " (- launch-delay delta) " seconds"))
 	    (thread-sleep! (- launch-delay delta))
 	    (loop (- (current-seconds) *last-launch*) launch-delay))))
     (change-directory *toppath*)
     (alist->env-vars ;; consolidate this code with the code in megatest.scm for "-execute", *maybe* - the longer they are set the longer each launch takes (must be non-overlapping with the vars)
      (append
@@ -1199,11 +1365,12 @@
 				  (if (equal? ush "no") ;; must use "no" to NOT use shell
 				      #f
 				      ush)
 				  #t)))     ;; default is yes
 	   (runscript       (config-lookup tconfig   "setup"        "runscript"))
-	   (ezsteps         (> (length (hash-table-ref/default tconfig "ezsteps" '())) 0)) ;; don't send all the steps, could be big
+	   (ezsteps         (> (length (hash-table-ref/default tconfig "ezsteps" '())) 0)) ;; don't send all the steps, could be big, just send a flag
+	   (subrun          (> (length (hash-table-ref/default tconfig "subrun"  '())) 0)) ;; send a flag to process a subrun
 	   ;; (diskspace       (config-lookup tconfig   "requirements" "diskspace"))
 	   ;; (memory          (config-lookup tconfig   "requirements" "memory"))
 	   ;; (hosts           (config-lookup *configdat* "jobtools"     "workhosts")) ;; I'm pretty sure this was never completed
 	   (remote-megatest (config-lookup *configdat* "setup" "executable"))
 	   (run-time-limit  (or (configf:lookup  tconfig   "requirements" "runtimelim")
@@ -1283,11 +1450,12 @@
 					(list 'run-id    run-id   )
 					(list 'test-id   test-id  )
 					;; (list 'item-path item-path )
 					(list 'itemdat   itemdat  )
 					(list 'megatest  remote-megatest)
-					(list 'ezsteps   ezsteps) 
+					(list 'ezsteps   ezsteps)
+					(list 'subrun    subrun)
 					(list 'target    mt_target)
 					(list 'contour   contour)
 					(list 'runtlim   (if run-time-limit (common:hms-string->seconds run-time-limit) #f))
 					(list 'env-ovrd  (hash-table-ref/default *configdat* "env-override" '())) 
 					(list 'set-vars  (if params (hash-table-ref/default params "-setvars" #f)))
@@ -1295,11 +1463,11 @@
 					(list 'mt-bindir-path mt-bindir-path))))))))
       
       ;; clean out step records from previous run if they exist
       ;; (rmt:delete-test-step-records run-id test-id)
       ;; if the dir does not exist we may have a itempath where individual variables are a path, launch anyway
-      (if (file-exists? work-area)
+      (if (common:file-exists? work-area)
 	  (change-directory work-area)) ;; so that log files from the launch process don't clutter the test dir
       (cond
        ;; ((and launcher hosts) ;; must be using ssh hostname
        ;;    (set! fullcmd (append launcher (car hosts)(list remote-megatest "-m" test-sig "-execute" cmdparms) debug-param)))
        ;; (set! fullcmd (append launcher (car hosts)(list remote-megatest test-sig "-execute" cmdparms))))
@@ -1328,23 +1496,28 @@
 				      itemdat)))
 	     (testprevvals   (alist->env-vars
 			      (hash-table-ref/default tconfig "pre-launch-env-overrides" '())))
 	     ;; Launchwait defaults to true, must override it to turn off wait
 	     (launchwait     (if (equal? (configf:lookup *configdat* "setup" "launchwait") "no") #f #t))
-	     (launch-results (apply (if launchwait
-					process:cmd-run-with-stderr->list
+	     (launch-results-prev (apply (if launchwait ;; BB: TODO: refactor this to examine return code of launcher, if nonzero, set state to launch failed.
+					process:cmd-run-with-stderr-and-exitcode->list
 					process-run)
 				    (if useshell
 					(let ((cmdstr (string-intersperse fullcmd " ")))
 					  (if launchwait
 					      cmdstr
 					      (conc cmdstr " >> mt_launch.log 2>&1 &")))
 					(car fullcmd))
 				    (if useshell
 					'()
-					(cdr fullcmd)))))
+					(cdr fullcmd))))
+             (success        (if launchwait (equal? 0 (cadr launch-results-prev)) #t))
+             (launch-results (if launchwait (car launch-results-prev) launch-results-prev)))
+        (if (not success)
+            (tests:test-set-status! run-id test-id "COMPLETED" "DEAD" "launcher failed; exited non-zero; check mt_launch.log" #f)) ;; (if launch-results launch-results "FAILED"))
         (mutex-unlock! *launch-setup-mutex*) ;; yes, really should mutex all the way to here. Need to put this entire process into a fork.
+	;; (rmt:no-sync-del! lock-key)         ;; release the lock for starting this test
 	(if (not launchwait) ;; give the OS a little time to allow the process to start
 	    (thread-sleep! 0.01))
 	(with-output-to-file "mt_launch.log"
 	  (lambda ()
 	    (print "LAUNCHCMD: " (string-intersperse fullcmd " "))

DELETED loadwatch/Makefile
Index: loadwatch/Makefile
==================================================================
--- loadwatch/Makefile
+++ /dev/null
@@ -1,11 +0,0 @@
-
-all : launch-many queuefeeder queuefeeder-server
-
-launch-many : launch-many.scm
-	csc launch-many.scm
-
-queuefeeder : queuefeeder.scm
-	csc queuefeeder.scm
-
-queuefeeder-server : queuefeeder-server.scm
-	csc queuefeeder-server.scm

DELETED loadwatch/bjob-count.sh
Index: loadwatch/bjob-count.sh
==================================================================
--- loadwatch/bjob-count.sh
+++ /dev/null
@@ -1,3 +0,0 @@
-#!/bin/bash
-
-bqueues | grep normal |awk '{print $8}'

DELETED loadwatch/launch-many.scm
Index: loadwatch/launch-many.scm
==================================================================
--- loadwatch/launch-many.scm
+++ /dev/null
@@ -1,9 +0,0 @@
-(use posix)
-
-(let loop ((count 0))
-  (if (> count 500000)
-      (print "DONE")
-      (let ((cmd (conc "./queuefeeder xena:22022 bsub ./testopenlava.sh " count " " (random 30))))
-	(print "Running: " cmd)
-	(system cmd)
-	(loop (+ count 1)))))

DELETED loadwatch/loadwatch.scm
Index: loadwatch/loadwatch.scm
==================================================================
--- loadwatch/loadwatch.scm
+++ /dev/null
@@ -1,86 +0,0 @@
-(use regex srfi-69)
-
-(define-record processdat
-  %cpu
-  virt
-  res
-  %mem
-  count
-  )
-
-(define (pp-processdat dat)
-  (print "(processdat"
-	 " %cpu="  (processdat-%cpu dat)
-	 " virt="  (processdat-virt dat)
-	 " res="   (processdat-res  dat)
-	 " %mem="  (processdat-%mem dat)
-	 " count=" (processdat-count dat)))
-
-
-(define nrex (regexp "^(\\d+[\\d\\.]*)([mkgMKG])$"))
-
-(define (get-number numstr)
-  (let ((n (string->number numstr)))
-    (if n 
-	n
-	(let ((nmatch (string-match nrex numstr)))
-	  (if nmatch
-	      (* (string->number (cadr nmatch))
-		 (case (string->symbol (caddr nmatch))
-		   ((k) 1024)
-		   ((m) 1048576)
-		   ((g) 1073741824)
-		   (else 
-		    (print "ERROR: Unrecognised unit: " (caddr nmatch) ", extracted for " numstr)
-		    1)))
-	      #f)))))
-
-
-(define (snagload)
-  (let ((dat (make-hash-table)) ;; user => hash-of-processdat
-	(hdr (regexp "^\\s+PID"))
-	(rx  (regexp "\\s+"))
-	(wht (regexp "^\\s+"))
-	)
-    (with-input-from-pipe 
-     "top -n 1 -b"
-     (lambda ()
-       (let loop ((inl   (read-line))
-		  (inbod #f))
-	 (if (eof-object? inl)
-	     dat
-	     (if (not inbod)
-		 (if (string-search hdr inl)
-		     (loop (read-line) #t)
-		     (loop (read-line) #f))
-		 (let* ((lparts (map (lambda (x)
-				       (let ((num (get-number x)))
-					 (if num num x)))
-				     (string-split-fields rx (string-substitute wht "" inl) #:infix))))
-		   (if (> (length lparts) 10)
-		       (let* ((user   (list-ref lparts 1))
-			      (virt   (list-ref lparts 4))
-			      (res    (list-ref lparts 5))
-			      (%cpu   (list-ref lparts 8))
-			      (%mem   (list-ref lparts 9))
-			      (time   (list-ref lparts 10))
-			      (pname  (list-ref lparts 11))
-			      (udat   (or (hash-table-ref/default dat user #f)
-					  (let ((u (make-hash-table)))
-					    (hash-table-set! dat user u)
-					    u)))
-			      (pdat   (or (hash-table-ref/default udat pname #f)
-					  (let ((p (make-processdat 0 0 0 0 0)))
-					    (hash-table-set! udat pname p)
-					    p))))
-			 (print "User: " user ", pname: " pname ", virt: " virt ", res: " res ", %cpu: " %cpu ", %mem: " %mem)
-			 (processdat-%cpu-set!  pdat (+ (processdat-%cpu pdat) %cpu))
-			 (processdat-%mem-set!  pdat (+ (processdat-%mem pdat) %mem))
-			 (processdat-virt-set!  pdat (+ (processdat-virt pdat) virt))
-			 (processdat-res-set!   pdat (+ (processdat-res pdat)  res))
-			 (processdat-count-set! pdat (+ (processdat-count pdat) 1))
-			 (loop (read-line) inbod))
-		       dat)))))))))
-    
-(define x (snagload))
-;; (processdat-%cpu (hash-table-ref (hash-table-ref x "matt") "evolution-calen"))

DELETED loadwatch/queuefeeder-server.scm
Index: loadwatch/queuefeeder-server.scm
==================================================================
--- loadwatch/queuefeeder-server.scm
+++ /dev/null
@@ -1,185 +0,0 @@
-;;======================================================================
-;; Copyright 2015-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 program is distributed WITHOUT ANY WARRANTY; without even the
-;;  implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
-;;  PURPOSE.
-;;======================================================================
-
-;; Queue Feeder. Use a crude droop curve to limit feeding jobs into a queue
-;;               to prevent slamming the queue
-
-;;======================================================================
-;; Methodology
-;;
-;;   Connect to the server, the server delays the appropriate time (if 
-;;   any) and then launch the task.
-;;
-
-(use nanomsg posix regex)
-
-;; (use trace)
-;; (trace nn-bind nn-socket nn-assert nn-recv nn-send thread-terminate! nn-close )
-
-(define port  22022)
-
-;; get needed stuff from commandline
-;;
-(define queuelen #f)
-(define cmd '()) ;; cmd is run to give a count of the queue length => returns number in queue
-
-(define usage "Usage: queuefeeder-server port target_queue_length command
-       where command is a script or program that gives an integer on stdout of current queue length")
-
-(let ((args (argv)))
-  (if (> (length args) 3)
-      (begin
-	(set! port     (cadr args))
-	(set! queuelen (string->number (caddr args)))
-	(set! cmd      (cadddr args))) ;; no params supported
-      (begin
-	(print usage)
-	(exit))))
-
-(if (not queuelen)
-    (begin
-      (print "queuelen must be a number")
-      (print usage)
-      (exit)))
-
-(print "Running queue feeder with port=" port ", command=" cmd)
-
-(define rep   (nn-socket 'rep))
-
-(print "connecting, got: " (nn-bind    rep  (conc "tcp://" "*" ":" port)))
-
-(define *current-delay* 0)
-(define (exp-droop-calc x targ)
-  (cond
-   ((> (- x targ) 1) 136) ;; top off at 136 seconds
-   (else 
-    (let ((res (* 50 (exp (- x targ)))))
-      (cond
-       ((and (> res 0)(< res 0.01)) 0.01)
-       ((> res 45)                  45) ;; cap at 45 seconds
-       (else res))))))
-
-;; x input value (current number in the queue)
-;; targ is the desired queue length
-;;
-(define (piecewise-droop-calc x targ)
-  (let ((top 50))
-    (cond
-     ((> (- x targ) 0)
-      top) ;; top off at top seconds
-     ((> x (- targ top))
-      (+ (* 1 (- x (- targ top)))
-	 (/ (- top targ) targ)))
-     (else (let ((res (/ x targ)))
-	     (if (< res 0.01)
-		 0.01
-		 res))))))
-
-(define (server soc)
-  (print "server starting")
-  (let loop ((msg-in (nn-recv soc))
-	     (count  0))
-    (if (eq? 0 (modulo count 1000))
-	(print "server received: " msg-in ", count=" count))
-    (cond
-     ((equal? msg-in "quit")
-      (nn-send soc "Ok, quitting"))
-     ((and (>= (string-length msg-in) 4)
-	   (equal? (substring msg-in 0 4) "ping"))
-      (nn-send soc (conc (current-process-id)))
-      (loop (nn-recv soc)(+ count 1)))
-     (else
-      (mutex-lock! *current-delay-mutex*)
-      (let ((current-delay *current-delay*))
-	(mutex-unlock! *current-delay-mutex*)
-	;; (thread-sleep! current-delay)
-	(nn-send soc (conc current-delay " hello " msg-in " you waited " current-delay " seconds"))
-	(loop (nn-recv soc)(if (> count 20000000)
-			       0
-			       (+ count 1))))))))
-
-(define (ping-self host port #!key (return-socket #t))
-  ;; send a random number along with pid and check that we get it back
-  (let* ((req     (nn-socket 'req))
-	 (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")))
-    (nn-connect req (conc "tcp://" host ":" port))
-    (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 " host ":" port))
-     (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))))
-
-(define *current-delay-mutex* (make-mutex))
-
-;; update the *current-delay* value every minute or QUEUE_CHK_DELAY seconds
-(thread-start! (make-thread (lambda ()
-			      (let ((delay-time (string->number (or (get-environment-variable "QUEUE_CHK_DELAY") "30"))))
-				(let loop ()
-				  (with-input-from-pipe 
-				   cmd  ;;; my query to get queue length
-				   (lambda ()
-				     (let* ((val       (read))
-					    (droop-val (if (number? val)(piecewise-droop-calc val queuelen) #f)))
-				       ;; val is number of jobs in queue. Use a linear droop of val/40
-				       (mutex-lock! *current-delay-mutex*)
-				       (set! *current-delay* (or droop-val 30)) ;; (/ (or droop-val 100) 50))
-				       (mutex-unlock! *current-delay-mutex*)
-				       (print "droop-val=" droop-val)
-				       (thread-sleep! delay-time))))
-				  (loop))))))
-
-(let ((server-thread (make-thread (lambda ()(server rep)) "server")))
-  (thread-start! server-thread)
-  (if (ping-self (get-host-name) port)
-      (begin
-	(thread-join! server-thread)
-	(nn-close rep))
-      (print "ping failed")))
-
-(exit)

DELETED loadwatch/queuefeeder.scm
Index: loadwatch/queuefeeder.scm
==================================================================
--- loadwatch/queuefeeder.scm
+++ /dev/null
@@ -1,96 +0,0 @@
-;;======================================================================
-;; Copyright 2015-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 program is distributed WITHOUT ANY WARRANTY; without even the
-;;  implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
-;;  PURPOSE.
-;;======================================================================
-
-;; Queue Feeder. Use a crude droop curve to limit feeding jobs into a queue
-;;               to prevent slamming the queue
-
-;;======================================================================
-;; Methodology
-;;
-;;   Connect to the server, the server delays the appropriate time (if 
-;;   any) and then launch the task.
-;;
-(use nanomsg posix regex message-digest md5)
-
-(define req   (nn-socket 'req))
-
-;; get needed stuff from commandline
-;;
-(define hostport #f)
-(define cmd '())
-
-(let ((args (argv)))
-  (if (> (length args) 2)
-      (begin
-	(set! hostport (cadr args))
-	(set! cmd      (cddr args)))
-      (begin
-	(print "Usage: queuefeeder host:port command params ....")
-	(exit))))
-
-(nn-connect req  (conc "tcp://" hostport)) ;; xena:22022")
-
-(define (client-send-receive soc msg)
-  (nn-send soc msg)
-  (nn-recv soc))
-
-;; Generate a unique signature for this client location
-;;
-(define (make-signature)
-  (message-digest-string (md5-primitive) 
-                         (with-output-to-string
-                           (lambda ()
-                             (write (current-directory))))))
-
-;; (define ((talk-to-server soc))
-;;   (let loop ((cnt 200000))
-;;     (let ((name (list-ref '("Matt" "Tom" "Bob" "Jill" "James" "Jane")(random 6))))
-;;       ;; (print "Sending " name)
-;;       ;; (print
-;;       (client-send-receive req name) ;; )
-;;       (if (> cnt 0)(loop (- cnt 1)))))
-;;   (print (client-send-receive req "quit"))
-;;   (nn-close req)
-;;   (exit))
-;; 
-
-(define (get-delay signature)
-  (let* ((full-msg   (client-send-receive req (conc (current-user-name) "@" (get-host-name) ":" signature))))
-    (print "Got " full-msg)
-    (let* ((reply-msg  (string-match "^([\\d\\.]+)\\s+(.*)$" full-msg))
-	   (delay-time (if (> (length reply-msg) 2)
-			   (string->number (cadr reply-msg))
-			   1)) ;; fall back to one sec delay
-	   (msg        (if (> (length reply-msg) 2)
-			   (caddr reply-msg)
-			   full-msg)))
-      (values delay-time msg))))
-
-
-(let ((signature (make-signature)))
-  
-  (thread-start! (lambda ()
-		   (thread-sleep! 60)
-		   (print "Give up on waiting for the server")
-		   ;; (nn-close req)
-		   ;; (exit)
-		   ))
-  (thread-join! (thread-start! (lambda ()
-				 (let-values 
-				  (((delay-time msg)(get-delay signature)))
-				  (print "INFO: sleeping " delay-time " seconds per request of queuefeeder server")
-				  (thread-sleep! delay-time)
-				  (print "INFO: done waiting, now executing requested task.")))))
-  (nn-close req))
-
-(process-execute (car cmd) (cdr cmd))
-
-

DELETED loadwatch/testopenlava.sh
Index: loadwatch/testopenlava.sh
==================================================================
--- loadwatch/testopenlava.sh
+++ /dev/null
@@ -1,9 +0,0 @@
-#!/bin/bash
-
-job_order=$1
-job_length=$2
-
-echo "START: $job_order" > $job_order.log
-sleep $job_length
-echo "END: $job_order" >> $job_order.log
-

Index: lock-queue.scm
==================================================================
--- lock-queue.scm
+++ lock-queue.scm
@@ -1,16 +1,24 @@
 ;; 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 sqlite3 srfi-18)
-(import (prefix sqlite3 sqlite3:))
+(use (prefix sqlite3 sqlite3:) srfi-18)
 
 (declare (unit lock-queue))
 (declare (uses common))
 (declare (uses tasks))
 
@@ -33,11 +41,11 @@
   (let ((fname (lock-queue:db-dat-get-path dbdat)))
     (system (conc "rm -f " fname "*"))))
 
 (define (lock-queue:open-db fname #!key (count 10))
   (let* ((actualfname (conc fname ".lockdb"))
-	 (dbexists (file-exists? actualfname))
+	 (dbexists (common:file-exists? actualfname))
 	 (db       (sqlite3:open-database actualfname))
 	 (handler  (make-busy-timeout 136000)))
     (if dbexists
 	(vector db actualfname)
 	(begin
@@ -164,12 +172,12 @@
 	     ;; If we've tried ten times and failed there is a serious problem
 	     ;; try to remove the lock db and allow it to be recreated
 	     (handle-exceptions
 	      exn
 	      #f
-	      (if (file-exists? journal)(delete-file journal))
-	      (if (file-exists? fname)  (delete-file fname))
+	      (if (common:file-exists? journal)(delete-file journal))
+	      (if (common:file-exists? fname)  (delete-file fname))
 	      #f))))
      (sqlite3:execute (lock-queue:db-dat-get-db dbdat) "DELETE FROM runlocks WHERE test_id=?;" test-id)
      (sqlite3:finalize! (lock-queue:db-dat-get-db dbdat)))))
 
 (define (lock-queue:steal-lock dbdat test-id #!key (count 10))

Index: megatest-version.scm
==================================================================
--- megatest-version.scm
+++ megatest-version.scm
@@ -1,7 +1,7 @@
 ;; Always use two or four digit decimal
 ;; 1.01, 1.02...1.10,1.11,1.1101 ... 1.99,2.00..
 
 (declare (unit megatest-version))
 
-(define megatest-version 1.6404)
+(define megatest-version 1.6509)
 

Index: megatest.config
==================================================================
--- megatest.config
+++ megatest.config
@@ -1,22 +1,58 @@
-[fields]
-a text
-b text
-c text
+
+## commented out due to a bug in v1.6501 in mtutil
+## [fields]
+## a text
+## b text
+## c text
+usercode    .mtutil.scm
+areafilter  area-to-run
+targtrans   generic-target-translator
+runtrans    generic-runname-translator
 
 [setup]
-pktsdirs /tmp/pkts /some/other/source
+pktsdirs /tmp/mt_pkts /some/other/source
 
 [areas]
 #         path-to-area   map-target-script(future, optional)
-fullrun   path=tests/fullrun
+# someqa     path=../megatestqa/someqa; targtrans=somefunc; areafilter=area-to-run
+fullrun   path=tests/fullrun; 
 # 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-tests path=ext-tests
+ext       path=ext-tests
 
 [contours]
-#     mode-patt/tag-expr
-quick selector=QUICKPATT/quick
-full  areas=fullrun,ext-tests; selector=MAXPATT/
-all   areas=fullrun,ext-tests
-snazy areas=%; selector=QUICKPATT/
+#     selector=tag-expr/mode-patt
+quick areas=ext;    selector=/QUICKPATT
+quick2 areafn=check-area; selector=/QUICKPATT
+# 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
+owner run rerun resume remove
+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]

Index: megatest.scm
==================================================================
--- megatest.scm
+++ megatest.scm
@@ -1,30 +1,37 @@
 ;; Copyright 2006-2017, 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 .
+;;
 
 ;; (include "common.scm")
 ;; (include "megatest-version.scm")
 
 ;; fake out readline usage of toplevel-command
 (define (toplevel-command . a) #f)
 
-(use sqlite3 srfi-1 posix regex regex-case srfi-69 base64 readline apropos json http-client directory-utils rpc typed-records;; (srfi 18) extras)
-     http-client srfi-18 extras format) ;;  zmq extras)
+(use (prefix sqlite3 sqlite3:) srfi-1 posix regex regex-case srfi-69 (prefix base64 base64:)
+     readline apropos json http-client directory-utils typed-records
+     http-client srfi-18 extras format)
 
 ;; Added for csv stuff - will be removed
 ;;
 (use sparse-vectors)
 
-(import (prefix sqlite3 sqlite3:))
-(import (prefix base64 base64:))
-(import (prefix rpc rpc:))
 (require-library mutils)
 
 ;; (use zmq)
 
 (declare (uses common))
@@ -44,42 +51,69 @@
 (declare (uses mt))
 (declare (uses api))
 (declare (uses tasks)) ;; only used for debugging.
 (declare (uses env))
 (declare (uses diff-report))
+(declare (uses ftail))
+(import ftail)
 
 (define *db* #f) ;; this is only for the repl, do not use in general!!!!
 
 (include "common_records.scm")
 (include "key_records.scm")
 (include "db_records.scm")
 (include "run_records.scm")
 (include "megatest-fossil-hash.scm")
 
+(define *usage-log-file* #f)    ;; put path to file for logging usage in this var in the ~/.megatestrc file
+(define *usage-use-seconds* #t) ;; for Epoc seconds in usage logging change this to #t in ~/.megatestrc file
+
+;; load the ~/.megatestrc file, put (use trace)(trace-call-sites #t)(trace function-you-want-to-trace) in this file
+;;
 (let ((debugcontrolf (conc (get-environment-variable "HOME") "/.megatestrc")))
-  (if (file-exists? debugcontrolf)
+  (if (common:file-exists? debugcontrolf)
       (load debugcontrolf)))
+
+;; usage logging, careful with this, it is not designed to deal with all real world challenges!
+;;
+(if (and *usage-log-file*
+         (file-write-access? *usage-log-file*))
+    (with-output-to-file
+        *usage-log-file*
+      (lambda ()
+        (print
+         (if *usage-use-seconds*
+             (current-seconds)
+             (time->string
+              (seconds->local-time (current-seconds))
+              "%Yww%V.%w %H:%M:%S"))
+         " "
+         (current-user-name) " "
+         (current-directory) " "
+         "\"" (string-intersperse (argv) " ") "\""))
+      #:append))
 
 ;; Disabled help items
 ;;  -rollup                 : (currently disabled) fill run (set by :runname)  with latest test(s)
 ;;                            from prior runs with same keys
 ;;  -daemonize              : fork into background and disconnect from stdin/out
 
 (define help (conc "
 Megatest, documentation at http://www.kiatoa.com/fossils/megatest
   version " megatest-version "
-  license GPL, Copyright Matt Welland 2006-2015
-
+  license GPL, Copyright Matt Welland 2006-2017
+ 
 Usage: megatest [options]
   -h                      : this help
   -manual                 : show the Megatest user manual
   -version                : print megatest version (currently " megatest-version ")
 
 Launching and managing runs
   -run                    : run all tests or as specified by -testpatt
   -remove-runs            : remove the data for a run, requires -runname and -testpatt
-                            Optionally use :state and :status
+                            Optionally use :state and :status, use -keep-records to remove only
+                            the run data.
   -set-state-status X,Y   : set state to X and status to Y, requires controls per -remove-runs
   -rerun FAIL,WARN...     : force re-run for tests with specificed status(s)
   -rerun-clean            : set all tests not COMPLETED+PASS,WARN,WAIVED to NOT_STARTED,n/a
                             and then run the specified testpatt with -preclean
   -rerun-all              : set all tests to NOT_STARTED,n/a and run with -preclean
@@ -89,20 +123,27 @@
   -get-run-status         : gets status for run specified by target and runname
   -run-wait               : wait on run specified by target and runname
   -preclean               : remove the existing test directory before running the test
   -clean-cache            : remove the cached megatest.config and runconfigs.config files
   -no-cache               : do not use the cached config files. 
+  -one-pass               : launch as many tests as you can but do not wait for more to be ready
+  -remove-keep N          : remove all but N most recent runs per target; use '-actions, -age, -precmd'
+  -age               : 120d,3h,20m to apply only to runs older than the 
+                                 specified age. NB// M=month, m=minute
+  -actions        : print,remove-runs,archive to specify action to take
+  -precmd                 : insert a wrapper command in front of the commands run
 
 Selectors (e.g. use for -runtests, -remove-runs, -set-state-status, -list-runs etc.)
   -target key1/key2/...   : run for key1, key2, etc.
   -reqtarg key1/key2/...  : run for key1, key2, etc. but key1/key2 must be in runconfigs
   -testpatt patt1/patt2,patt3/...  : % is wildcard
   -runname                : required, name for this particular test run
   -state                  : Applies to runs, tests or steps depending on context
   -status                 : Applies to runs, tests or steps depending on context
-  --modepatt key          : load testpatt from  in runconfigs instead of default TESTPATT if -testpatt and -tagexpr are not specified
+  -modepatt key           : load testpatt from  in runconfigs instead of default TESTPATT if -testpatt and -tagexpr are not specified
   -tagexpr tag1,tag2%,..  : select tests with tags matching expression
+  
 
 Test helpers (for use inside tests)
   -step stepname
   -test-status            : set the state and status of a test (use :state and :status)
   -setlog logfname        : set the path/filename to the final log relative to the test
@@ -133,21 +174,23 @@
   -list-disks             : list the disks available for storing runs
   -list-targets           : list the targets in runconfigs.config
   -list-db-targets        : list the target combinations used in the db
   -show-config            : dump the internal representation of the megatest.config file
   -show-runconfig         : dump the internal representation of the runconfigs.config file
-  -dumpmode MODE          : dump in MODE format instead of sexpr, MODE=json,ini,sexp etc.
+  -dumpmode MODE          : dump in MODE format instead of sexpr, MODE=json,ini,sexp etc. (add -debug 0,9 to see which file contributes each line)
   -show-cmdinfo           : dump the command info for a test (run in test environment)
   -section sectionName
   -var varName            : for config and runconfig lookup value for sectionName varName
   -since N                : get list of runs changed since time N (Unix seconds)
   -fields fieldspec       : fields to include in json dump; runs:id,runame+tests:testname+steps
   -sort fieldname         : in -list-runs sort tests by this field
+  -testdata-csv [categorypatt/]varpatt  : dump testdata for given category
 
 Misc 
   -start-dir path         : switch to this directory before running megatest
   -contour cname          : add a level of hierarcy to the linktree and run paths
+  -area-tag tagname       : add a tag to an area while syncking to pgdb
   -rebuild-db             : bring the database schema up to date
   -cleanup-db             : remove any orphan records, vacuum the db
   -import-megatest.db     : push data from megatest.db to cache db files in /tmp/$USER
   -sync-to-megatest.db    : pull data from cache files in /tmp/$USER to megatest.db
   -sync-to dest           : sync to new postgresql central style database
@@ -180,11 +223,19 @@
                             multiple sheets)
   -o                      : output file for refdb2dat (defaults to stdout)
   -archive cmd            : archive runs specified by selectors to one of disks specified
                             in the [archive-disks] section.
                             cmd: keep-html, restore, save, save-remove
-  -generate-html          : create a simple html tree for browsing your runs
+  -generate-html          : create a simple html dashboard for browsing your runs
+  -generate-html-structure  : create a top level html veiw to list targets/runs and a Run view within each run directory.  
+  -list-run-time          : list time requered to complete runs. It supports following switches
+                            -run-patt  -target-patt  -dumpmode 
+  -list-test-time	   : list time requered to complete each test in a run. It following following arguments
+                            -runname  -target  -dumpmode 
+
+  		
+
 
 Diff report
   -diff-rep               : generate diff report (must include -src-target, -src-runname, -target, -runname
                                                   and either -diff-email or -diff-html)
   -src-target 
@@ -228,12 +279,14 @@
 			":state"  
 			"-state"
 			":status"
 			"-status"
 			"-list-runs"
+                        "-testdata-csv"
 			"-testpatt"
                         "--modepatt"
+                        "-modepatt"
                         "-tagexpr"
 			"-itempatt"
 			"-setlog"
 			"-set-toplog"
 			"-runstep"
@@ -250,11 +303,14 @@
 			":expected"
 			":tol"
 			":units"
 			;; misc
 			"-start-dir"
+                        "-run-patt"
+                        "-target-patt"   
 			"-contour"
+                        "-area-tag"  
 			"-server"
 			"-transport"
 			"-port"
 			"-extract-ods"
 			"-pathmod"
@@ -261,11 +317,19 @@
 			"-env2file"
 			"-envcap"
 			"-envdelta"
 			"-setvars"
 			"-set-state-status"
+
+                        ;; move runs stuff here
+                        "-remove-keep"           
 			"-set-run-status"
+			"-age"
+			"-archive"
+			"-actions"
+			"-precmd"
+			
 			"-debug" ;; for *verbosity* > 2
 			"-create-test"
 			"-override-timeout"
 			"-test-files"  ;; -test-paths is for listing all
 			"-load"        ;; load and exectute a scheme file
@@ -275,11 +339,10 @@
 			"-run-id"
 			"-ping"
 			"-refdb2dat"
 			"-o"
 			"-log"
-			"-archive"
 			"-since"
 			"-fields"
 			"-recover-test" ;; run-id,test-id - used internally to recover a test stuck in RUNNING state
 			"-sort"
 			"-target-db"
@@ -319,13 +382,16 @@
 			"-lock"
 			"-unlock"
 			"-list-servers"
 			"-kill-servers"
                         "-run-wait"      ;; wait on a run to complete (i.e. no RUNNING)
+			"-one-pass"       ;;
 			"-local"         ;; run some commands using local db access
-                        "-generate-html"
-
+      "-generate-html"
+      "-generate-html-structure" 
+			"-list-run-time"
+                        "-list-test-time"
 			;; misc queries
 			"-list-disks"
 			"-list-targets"
 			"-list-db-targets"
 			"-show-runconfig"
@@ -337,10 +403,11 @@
 			"-test-paths" ;; get path(s) to a test, ordered by youngest first
 
 			"-runall"    ;; run all tests, respects -testpatt, defaults to %
 			"-run"       ;; alias for -runall
 			"-remove-runs"
+                        "-keep-records" ;; use with -remove-runs to remove only the run data
 			"-rebuild-db"
 			"-cleanup-db"
 			"-rollup"
 			"-update-meta"
 			"-create-megatest-area"
@@ -348,11 +415,10 @@
 
 			"-convert-to-norm"
 			"-convert-to-old"
 			"-import-megatest.db"
 			"-sync-to-megatest.db"
-			
 			"-logging"
 			"-v" ;; verbose 2, more than normal (normal is 1)
 			"-q" ;; quiet 0, errors/warnings only
 
                         "-diff-rep"
@@ -372,11 +438,11 @@
     (debug:print-error 0 *default-log-port* "Unrecognised arguments: " (string-intersperse (if (list? remargs) remargs (argv))  " ")))
 
 ;; before doing anything else change to the start-dir if provided
 ;;
 (if (args:get-arg "-start-dir")
-    (if (file-exists? (args:get-arg "-start-dir"))
+    (if (common:file-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.")
@@ -389,25 +455,35 @@
 
 ;; The watchdog is to keep an eye on things like db sync etc.
 ;;
 
 ;; TODO: for multiple areas, we will have multiple watchdogs; and multiple threads to manage
-(define *watchdog* (make-thread common:watchdog "Watchdog thread"))
+(define *watchdog* (make-thread
+		    (lambda ()
+		      (handle-exceptions
+			  exn
+			  (begin
+			    (print-call-chain)
+			    (print " message: " ((condition-property-accessor 'exn 'message) exn)))
+			(common:watchdog)))
+		    "Watchdog thread"))
 
 ;;(if (not (args:get-arg "-server"))
 ;;    (thread-start! *watchdog*)) ;; if starting a server; wait till we get to running state before kicking off watchdog
 (let* ((no-watchdog-args
        '("-list-runs"
+         "-testdata-csv"
          "-list-servers"
          "-server"
          "-list-disks"
          "-list-targets"
          "-show-runconfig"
          ;;"-list-db-targets"
          "-show-runconfig"
          "-show-config"
-         "-show-cmdinfo"))
+         "-show-cmdinfo"
+	 "-cleanup-db"))
        (no-watchdog-args-vals (filter (lambda (x) x)
                                       (map args:get-arg no-watchdog-args)))
        (start-watchdog (null? no-watchdog-args-vals)))
   ;;(BB> "no-watchdog-args="no-watchdog-args "no-watchdog-args-vals="no-watchdog-args-vals) 
   (if start-watchdog
@@ -424,18 +500,21 @@
    (exn ()
         (debug:print-error 0 *default-log-port* "Could not open log file for write: "logpath)
         (define *didsomething* #t)  
         (exit 1))))
 
-    
+;; this segment will run launch:setup only if -log is not set. This is fairly safe as servers are not
+;; manually started and thus should never be started in a non-megatest area. Thus no need to handle situation
+;; where (launch:setup) returns #f?
+;;
 (if (or (args:get-arg "-log")(args:get-arg "-server")) ;; redirect the log always when a server
     (handle-exceptions
 	exn
 	(begin
-	  (print "ERROR: Failed to switch to log output. " ((conition-property-accessor 'exn 'message) exn))
+	  (print "ERROR: Failed to switch to log output. " ((condition-property-accessor 'exn 'message) exn))
 	  )
-      (let* ((tl   (or (args:get-arg "-log")(launch:setup)))   ;; run launch:setup if -server
+      (let* ((tl   (or (args:get-arg "-log")(launch:setup)))   ;; run launch:setup if -server, ensure we do NOT run launch:setup if -log specified
 	     (logf (or (args:get-arg "-log") ;; use -log unless we are a server, then craft a logfile name
 		       (conc tl "/logs/server-" (current-process-id) "-" (get-host-name) ".log")))
 	     (oup  (open-logfile logf)))
 	(if (not (args:get-arg "-log"))
 	    (hash-table-set! args:arg-hash "-log" logf)) ;; fake out future queries of -log
@@ -453,11 +532,11 @@
     (let* ((htmlviewercmd (or (configf:lookup *configdat* "setup" "htmlviewercmd")
 			      (common:which '("firefox" "arora"))))
 	   (install-home  (common:get-install-area))
 	   (manual-html   (conc install-home "/share/docs/megatest_manual.html")))
       (if (and install-home
-	       (file-exists? manual-html))
+	       (common:file-exists? manual-html))
 	  (system (conc "(" htmlviewercmd " " manual-html " ) &"))
 	  (system (conc "(" htmlviewercmd " http://www.kiatoa.com/cgi-bin/fossils/megatest/doc/tip/docs/manual/megatest_manual.html ) &")))
       (exit)))
 
 (if (args:get-arg "-version")
@@ -494,10 +573,24 @@
 
 ;; for some switches always print the command to stderr
 ;;
 (if (args:any? "-run" "-runall" "-remove-runs" "-set-state-status")
     (debug:print 0 *default-log-port* (string-intersperse (argv) " ")))
+
+;; some switches imply homehost. Exit here if not on homehost
+;;
+(let ((homehost-required  (list "-cleanup-db" "-server")))
+  (if (apply args:any? homehost-required)
+      (if (not (common:on-homehost?))
+	  (for-each
+	   (lambda (switch)
+	     (if (args:get-arg switch)
+		 (begin
+		   (debug:print 0 *default-log-port* "ERROR: you must be on the homehost to run with " switch
+				", you can move homehost by removing the .homehost file but this will disrupt any runs in progress.")
+		   (exit 1))))
+	   homehost-required))))
 
 ;;======================================================================
 ;; Misc setup stuff
 ;;======================================================================
 
@@ -534,11 +627,15 @@
 ;; handle a clean-cache request as early as possible
 ;;
 (if (args:get-arg "-clean-cache")
     (let ((toppath  (launch:setup)))
       (set! *didsomething* #t) ;; suppress the help output.
-      (runs:clean-cache (getenv "MT_TARGET")(args:get-arg "-runname") toppath)))
+      (runs:clean-cache (or (getenv "MT_TARGET")
+			    (args:get-arg "-target")
+			    (args:get-arg "-remtarg"))
+			(args:get-arg "-runname")
+			toppath)))
 	  
 (if (args:get-arg "-env2file")
     (begin
       (save-environment-as-files (args:get-arg "-env2file"))
       (set! *didsomething* #t)))
@@ -690,11 +787,11 @@
 				 (else
 				  (loop row (+ col 1) (append curr-row (list val)) result)))))))))
 		    (hash-table-keys results))))
 		((sqlite3)
 		 (let* ((db-file   (or out-file (pathname-file input-db)))
-			(db-exists (file-exists? db-file))
+			(db-exists (common:file-exists? db-file))
 			(db        (sqlite3:open-database db-file)))
 		   (if (not db-exists)(sqlite3:execute db "CREATE TABLE data (sheet,section,var,val);"))
 		   (configf:map-all-hier-alist
 		    data
 		    (lambda (sheetname sectionname varname val)
@@ -838,11 +935,11 @@
   (let* ((rundir (if (and (getenv "MT_LINKTREE")(getenv "MT_TARGET")(getenv "MT_RUNNAME"))
 		     (conc (getenv "MT_LINKTREE") "/" (getenv "MT_TARGET") "/" (getenv "MT_RUNNAME"))
 		     #f))
 	 (cfgf   (if rundir (conc rundir "/.runconfig." megatest-version "-" megatest-fossil-hash) #f)))
     (if (and cfgf
-	     (file-exists? cfgf)
+	     (common:file-exists? cfgf)
 	     (file-write-access? cfgf)
 	     (common:use-cache?))
 	(configf:read-alist cfgf)
 	(let* ((keys   (rmt:get-keys))
 	       (target (common:args-get-target))
@@ -861,12 +958,13 @@
 		   (file-write-access? rundir))
 	      (begin
                 (if (not (common:in-running-test?))
                     (configf:write-alist data cfgf))
 		;; force re-read of megatest.config - this resolves circular references between megatest.config
-		(launch:setup force: #t)
-		(launch:cache-config))) ;; we can safely cache megatest.config since we have a valid runconfig
+		(launch:setup force-reread: #t)
+		;; (launch:cache-config) ;; there are two independent config cache locations, turning this one off for now. MRW.
+		)) ;; we can safely cache megatest.config since we have a valid runconfig
 	  data))))
 
 (if (args:get-arg "-show-runconfig")
     (let ((tl (launch:setup)))
       (push-directory *toppath*)
@@ -928,11 +1026,11 @@
 ;; Remove old run(s)
 ;;======================================================================
 
 ;; since several actions can be specified on the command line the removal
 ;; is done first
-(define (operate-on action)
+(define (operate-on action #!key (mode #f)) ;; #f is "use default"
   (let* ((runrec (runs:runrec-make-record))
 	 (target (common:args-get-target)))
     (cond
      ((not target)
       (debug:print-error 0 *default-log-port* "Missing required parameter for " action ", you must specify -target or -reqtarg")
@@ -957,19 +1055,36 @@
 			      target
 			      (common:args-get-runname)  ;; (or (args:get-arg "-runname")(args:get-arg ":runname"))
 			      (common:args-get-testpatt #f) ;; (args:get-arg "-testpatt")
 			      state: (common:args-get-state)
 			      status: (common:args-get-status)
-			      new-state-status: (args:get-arg "-set-state-status"))))
+			      new-state-status: (args:get-arg "-set-state-status")
+                              mode: mode)))
       (set! *didsomething* #t)))))
 
 (if (args:get-arg "-remove-runs")
     (general-run-call 
      "-remove-runs"
      "remove runs"
      (lambda (target runname keys keyvals)
-       (operate-on 'remove-runs))))
+       (operate-on 'remove-runs mode: (if (args:get-arg "-keep-records")
+                                          'remove-data-only
+                                          'remove-all)))))
+
+(if (args:get-arg "-remove-keep")
+    (general-run-call 
+     "-remove-keep"
+     "remove keep"
+     (lambda (target runname keys keyvals)
+       (let ((actions (map string->symbol
+                           (string-split
+			    (or (args:get-arg "-actions")
+				"print")
+			    ",")))) ;; default to printing the output
+         (runs:remove-all-but-last-n-runs-per-target target runname
+						     (string->number (args:get-arg "-remove-keep"))
+						     actions: actions)))))
 
 (if (args:get-arg "-set-state-status")
     (general-run-call 
      "-set-state-status"
      "set state and status"
@@ -1023,10 +1138,114 @@
     (if indx
 	(if (>= indx (vector-length datavec))
 	    #f ;; index too high, should raise an error I suppose
 	    (vector-ref datavec indx))
 	#f)))
+
+
+
+
+
+(when (args:get-arg "-testdata-csv")
+  (if (launch:setup)
+      (let* ((keys        (rmt:get-keys)) ;; (db:get-keys dbstruct))
+             (runpatt     (or (args:get-arg "-runname") "%"))
+             (testpatt    (common:args-get-testpatt #f))
+             (datapatt    (args:get-arg "-testdata-csv"))
+             (match-data  (string-match "^([^/]+)/(.*)" (args:get-arg "-testdata-csv")))
+             (categorypatt (if match-data (list-ref match-data 1) "%"))
+             (setvarpatt  (if match-data
+                              (list-ref match-data 2)
+                              (args:get-arg "-testdata-csv")))
+             (runsdat     (rmt:get-runs-by-patt keys (or runpatt "%") 
+                                                (common:args-get-target) #f #f '("id" "runname" "state" "status" "owner" "event_time" "comment") 0))
+             (header      (db:get-header runsdat))
+             (access-mode (db:get-access-mode))
+             (testpatt    (common:args-get-testpatt #f))
+             (fields-spec (if (args:get-arg "-fields")
+                              (extract-fields-constraints (args:get-arg "-fields"))
+                              (list (cons "runs" (append keys (list "id" "runname" "state" "status" "owner" "event_time" "comment" "fail_count" "pass_count")))
+                                    (cons "tests"  db:test-record-fields) ;; "id" "testname" "test_path")
+                                    (list "steps" "id" "stepname"))))
+             (tests-spec  (let ((t (alist-ref "tests" fields-spec equal?)))
+                            (if (and t (null? t)) ;; all fields
+                                db:test-record-fields
+                                t)))
+             (adj-tests-spec (delete-duplicates (if tests-spec (cons "id" tests-spec) db:test-record-fields))) 
+             (test-field-index (make-hash-table))
+             (runs (db:get-rows runsdat))
+             )
+        (if (and tests-spec (not (null? tests-spec))) ;; do some validation and processing of the test-spec
+            (let ((invalid-tests-spec (filter (lambda (x)(not (member x db:test-record-fields))) tests-spec)))
+              (if (null? invalid-tests-spec)
+                  ;; generate the lookup map test-field-name => index-number
+                  (let loop ((hed (car adj-tests-spec))
+                             (tal (cdr adj-tests-spec))
+                             (idx 0))
+                    (hash-table-set! test-field-index hed idx)
+                    (if (not (null? tal))(loop (car tal)(cdr tal)(+ idx 1))))
+                  (begin
+                    (debug:print-error 0 *default-log-port* "Invalid test fields specified: " (string-intersperse invalid-tests-spec ", "))
+                    (exit)))))
+        (let* ((table-header (string-split "target,run,test,itempath,category,var,value,comment" ","))
+               (table-rows
+                (apply append (map  
+                               (lambda (run)
+                                 (let* ((target (string-intersperse (map (lambda (x)
+							 (db:get-value-by-header run header x))
+						       keys) "/"))
+                                        (statuses (string-split (or (args:get-arg "-status") "") ","))
+                                        (run-id  (db:get-value-by-header run header "id"))
+                                        (runname (db:get-value-by-header run header "runname")) 
+                                        (states  (string-split (or (args:get-arg "-state") "") ","))
+                                        (tests   (if tests-spec
+                                                     (db:dispatch-query access-mode rmt:get-tests-for-run db:get-tests-for-run run-id testpatt states statuses #f #f #f 'testname 'asc ;; (db:get-tests-for-run dbstruct run-id testpatt '() '() #f #f #f 'testname 'asc 
+                                                                        ;; use qryvals if test-spec provided
+                                                                        (if tests-spec
+                                                                            (string-intersperse adj-tests-spec ",")
+                                                                            ;; db:test-record-fields
+                                                                            #f)
+                                                                        #f
+                                                                        'normal)
+                                                     '())))
+                                   (apply append
+                                          (map
+                                           (lambda (test)
+                                             (let* (
+                                                    (test-id      (if (member "id"           tests-spec)(get-value-by-fieldname test test-field-index "id"          ) #f)) ;; (db:test-get-id         test))
+                                                    (testname     (if (member "testname"     tests-spec)(get-value-by-fieldname test test-field-index "testname"    ) #f)) ;; (db:test-get-testname   test))
+                                                    (itempath     (if (member "item_path"    tests-spec)(get-value-by-fieldname test test-field-index "item_path"   ) #f)) ;; (db:test-get-item-path  test))
+                                                    (fullname     (conc testname
+                                                                        (if (equal? itempath "")
+                                                                            "" 
+                                                                            (conc "/" itempath ))))
+                                                    (testdat-raw (map vector->list (rmt:read-test-data* run-id test-id categorypatt setvarpatt)))
+                                                    (testdat (filter
+                                                              (lambda (x)
+                                                                (not (equal? "logpro"
+                                                                             (list-ref x 10))))
+                                                              testdat-raw)))
+                                               (map 
+                                                (lambda (item)
+                                                  (receive (id test_id category
+                                                               variable value expected
+                                                               tol units comment status type)
+                                                      (apply values item)
+                                                    (list target runname testname itempath category variable value comment)))
+                                                testdat)))
+                                           tests))))
+                               runs))))
+          (print (string-join table-header ","))
+          (for-each (lambda(table-row)
+                      (print (string-join (map ->string table-row) ",")))
+
+                    
+                            table-rows))))
+  (set! *didsomething* #t)
+  (set! *time-to-exit* #t))
+
+
 
 ;; NOTE: list-runs and list-db-targets operate on local db!!!
 ;;
 ;; IDEA: megatest list -runname blah% ...
 ;;
@@ -1160,11 +1379,11 @@
 		      (lambda (test)
 		      	(common:debug-handle-exceptions #f
 			 exn
 			 (begin
 			   (debug:print-error 0 *default-log-port* "Bad data in test record? " test)
-			   (print "exn=" (condition->list exn))
+			   (debug:print-error 5 *default-log-port* "exn=" (condition->list exn))
 			   (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
 			   (print-call-chain (current-error-port)))
 			 (let* ((test-id      (if (member "id"           tests-spec)(get-value-by-fieldname test test-field-index "id"          ) #f)) ;; (db:test-get-id         test))
 				(testname     (if (member "testname"     tests-spec)(get-value-by-fieldname test test-field-index "testname"    ) #f)) ;; (db:test-get-testname   test))
 				(itempath     (if (member "item_path"    tests-spec)(get-value-by-fieldname test test-field-index "item_path"   ) #f)) ;; (db:test-get-item-path  test))
@@ -1403,61 +1622,63 @@
 (if (or (args:get-arg "-runall")
 	(args:get-arg "-run")
 	(args:get-arg "-rerun-clean")
 	(args:get-arg "-rerun-all")
 	(args:get-arg "-runtests"))
-    (general-run-call 
-     "-runall"
-     "run all tests"
-     (lambda (target runname keys keyvals)
-       (if (args:get-arg "-rerun-clean") ;; first set states/statuses correct
-	   (let ((states   (or (configf:lookup *configdat* "validvalues" "cleanrerun-states")
-			       "KILLREQ,KILLED,UNKNOWN,INCOMPLETE,STUCK,NOT_STARTED"))
-		 (statuses (or (configf:lookup *configdat* "validvalues" "cleanrerun-statuses")
-			       "FAIL,INCOMPLETE,ABORT,CHECK")))
-	     (hash-table-set! args:arg-hash "-preclean" #t)
-	     (runs:operate-on 'set-state-status
-			      target
-			      (common:args-get-runname)  ;; (or (args:get-arg "-runname")(args:get-arg ":runname"))
-			      "%" ;; (common:args-get-testpatt #f) ;; (args:get-arg "-testpatt")
-			      state:  states
-			      ;; status: statuses
-			      new-state-status: "NOT_STARTED,n/a")
-	     (runs:clean-cache target runname *toppath*)
-	     (runs:operate-on 'set-state-status
-			      target
-			      (common:args-get-runname)  ;; (or (args:get-arg "-runname")(args:get-arg ":runname"))
-			      "%" ;; (common:args-get-testpatt #f) ;; (args:get-arg "-testpatt")
-			      ;; state:  states
-			      status: statuses
-			      new-state-status: "NOT_STARTED,n/a")))
-       ;; RERUN ALL
-       (if (args:get-arg "-rerun-all") ;; first set states/statuses correct
-	   (begin
-	     (hash-table-set! args:arg-hash "-preclean" #t)
-	     (runs:operate-on 'set-state-status
-			      target
-			      (common:args-get-runname)  ;; (or (args:get-arg "-runname")(args:get-arg ":runname"))
-			      "%" ;; (common:args-get-testpatt #f) ;; (args:get-arg "-testpatt")
-			      state:  #f
-			      ;; status: statuses
-			      new-state-status: "NOT_STARTED,n/a")
-	     (runs:clean-cache target runname *toppath*)
-	     (runs:operate-on 'set-state-status
-			      target
-			      (common:args-get-runname)  ;; (or (args:get-arg "-runname")(args:get-arg ":runname"))
-			      "%" ;; (common:args-get-testpatt #f) ;; (args:get-arg "-testpatt")
-			      ;; state:  states
-			      status: #f
-			      new-state-status: "NOT_STARTED,n/a")))
-       (runs:run-tests target
-		       runname
-		       #f ;; (common:args-get-testpatt #f)
-		       ;; (or (args:get-arg "-testpatt")
-		       ;;     "%")
-		       user
-		       args:arg-hash))))
+    (let ((need-clean (or (args:get-arg "-rerun-clean")
+                          (args:get-arg "-rerun-all"))))
+      (general-run-call 
+       "-runall"
+       "run all tests"
+       (lambda (target runname keys keyvals)
+         (if (args:get-arg "-rerun-clean") ;; first set states/statuses correct
+             (let ((states   (or (configf:lookup *configdat* "validvalues" "cleanrerun-states")
+                                 "KILLREQ,KILLED,UNKNOWN,INCOMPLETE,STUCK,NOT_STARTED"))
+                   (statuses (or (configf:lookup *configdat* "validvalues" "cleanrerun-statuses")
+                                 "FAIL,INCOMPLETE,ABORT,CHECK,DEAD,PREQ_FAIL,PREQ_DISCARDED")))
+               (hash-table-set! args:arg-hash "-preclean" #t)
+               (runs:operate-on 'set-state-status
+                                target
+                                (common:args-get-runname)  ;; (or (args:get-arg "-runname")(args:get-arg ":runname"))
+                                "%" ;; (common:args-get-testpatt #f) ;; (args:get-arg "-testpatt")
+                                state:  states
+                                ;; status: statuses
+                                new-state-status: "NOT_STARTED,n/a")
+               (runs:clean-cache target runname *toppath*)
+               (runs:operate-on 'set-state-status
+                                target
+                                (common:args-get-runname)  ;; (or (args:get-arg "-runname")(args:get-arg ":runname"))
+                                "%" ;; (common:args-get-testpatt #f) ;; (args:get-arg "-testpatt")
+                                ;; state:  states
+                                status: statuses
+                                new-state-status: "NOT_STARTED,n/a")))
+         ;; RERUN ALL
+         (if (args:get-arg "-rerun-all") ;; first set states/statuses correct
+             (begin
+               (hash-table-set! args:arg-hash "-preclean" #t)
+               (runs:operate-on 'set-state-status
+                                target
+                                (common:args-get-runname)  ;; (or (args:get-arg "-runname")(args:get-arg ":runname"))
+                                "%" ;; (common:args-get-testpatt #f) ;; (args:get-arg "-testpatt")
+                                state:  #f
+                                ;; status: statuses
+                                new-state-status: "NOT_STARTED,n/a")
+               (runs:clean-cache target runname *toppath*)
+               (runs:operate-on 'set-state-status
+                                target
+                                (common:args-get-runname)  ;; (or (args:get-arg "-runname")(args:get-arg ":runname"))
+                                "%" ;; (common:args-get-testpatt #f) ;; (args:get-arg "-testpatt")
+                                ;; state:  states
+                                status: #f
+                                new-state-status: "NOT_STARTED,n/a")))
+         (runs:run-tests target
+                         runname
+                         #f ;; (common:args-get-testpatt #f)
+                         ;; (or (args:get-arg "-testpatt")
+                         ;;     "%")
+                         user
+                         args:arg-hash)))))
 
 ;;======================================================================
 ;; run one test
 ;;======================================================================
 
@@ -1559,11 +1780,11 @@
 	  (let* ((keys     (rmt:get-keys))
 		 ;; db:test-get-paths must not be run remote
 		 (paths    (tests:test-get-paths-matching keys target (args:get-arg "-test-files"))))
 	    (set! *didsomething* #t)
 	    (for-each (lambda (path)
-			(if (file-exists? path)
+			(if (common:file-exists? path)
 			(print path)))	
 		      paths)))
 	;; else do a general-run-call
 	(general-run-call 
 	 "-test-files"
@@ -1849,20 +2070,22 @@
       (if (not (launch:setup))
 	  (begin
 	    (debug:print 0 *default-log-port* "Failed to setup, exiting") 
 	    (exit 1)))
       ;; keep this one local
-      (open-run-close patch-db #f)
+      ;; (open-run-close patch-db #f)
+      (let ((dbstruct (db:setup #f areapath: *toppath*)))
+        (common:cleanup-db dbstruct full: #t))
       (set! *didsomething* #t)))
 
 (if (args:get-arg "-cleanup-db")
     (begin
       (if (not (launch:setup))
 	  (begin
 	    (debug:print 0 *default-log-port* "Failed to setup, exiting") 
 	    (exit 1)))
-      (let ((dbstruct (db:setup *toppath*)))
+      (let ((dbstruct (db:setup #f areapath: *toppath*)))
         (common:cleanup-db dbstruct))
       (set! *didsomething* #t)))
 
 (if (args:get-arg "-mark-incompletes")
     (begin
@@ -1917,11 +2140,11 @@
 	(args:get-arg "-repl")
 	(args:get-arg "-load"))
     (let* ((toppath (launch:setup))
 	   (dbstruct (if (and toppath
                               (common:on-homehost?))
-                         (db:setup)
+                         (db:setup #t)
                          #f))) ;; make-dbr:dbstruct path: toppath local: (args:get-arg "-local")) #f)))
       (if *toppath*
 	  (cond
 	   ((getenv "MT_RUNSCRIPT")
 	    ;; How to run megatest scripts
@@ -2006,39 +2229,54 @@
 ;; ;; ;; redo me       (set! *didsomething* #t)))
 
 (if (args:get-arg "-import-megatest.db")
     (begin
       (db:multi-db-sync 
-       (db:setup)
+       (db:setup #f)
        'killservers
        'dejunk
        'adj-testids
        'old2new
        ;; 'new2old
        )
       (set! *didsomething* #t)))
 
 (if (args:get-arg "-sync-to-megatest.db")
-    (begin
-      (db:multi-db-sync 
-       (db:setup)
-       'new2old
-       )
+    (let ((res (db:multi-db-sync 
+                (db:setup #f)
+                'new2old)))
+      (print "Synced " res " records to megatest.db")
       (set! *didsomething* #t)))
 
 (if (args:get-arg "-sync-to")
     (let ((toppath (launch:setup)))
       (tasks:sync-to-postgres *configdat* (args:get-arg "-sync-to"))
       (set! *didsomething* #t)))
 
+(if (args:get-arg "-list-test-time")
+     (let* ((toppath (launch:setup))) 
+     (task:get-test-times)  
+     (set! *didsomething* #t)))
+
+(if (args:get-arg "-list-run-time")
+     (let* ((toppath (launch:setup))) 
+     (task:get-run-times)  
+     (set! *didsomething* #t)))
+     
 (if (args:get-arg "-generate-html")
     (let* ((toppath (launch:setup)))
       (if (tests:create-html-tree #f)
           (debug:print-info 0 *default-log-port* "HTML output created in " toppath "/lt/page#.html")
           (debug:print 0 *default-log-port* "Failed to create HTML output in " toppath "/lt/runs-index.html"))
       (set! *didsomething* #t)))
-
+(if (args:get-arg "-generate-html-structure")
+    (let* ((toppath (launch:setup)))
+      ;(if (tests:create-html-tree #f)
+ 				(if (tests:create-html-summary #f)
+          (debug:print-info 0 *default-log-port* "HTML output created in " toppath "/lt/targets.html")
+          (debug:print 0 *default-log-port* "Failed to create HTML output in " toppath "/lt/runs-index.html"))
+      (set! *didsomething* #t)))
 ;;======================================================================
 ;; Exit and clean up
 ;;======================================================================
 
 (if (not *didsomething*)

ADDED   minimt/Makefile
Index: minimt/Makefile
==================================================================
--- /dev/null
+++ minimt/Makefile
@@ -0,0 +1,12 @@
+minimt : minimt.scm db.scm setup.scm direct.scm
+	csc minimt.scm
+
+run    : minimt
+	export PATH="$(PWD)":$(PATH) ; minimt runrun foo/bar run1 
+
+runseq : clean run 
+	sleep 5;tail -F runtest/*log
+
+clean :
+	rm -rf runtest/*
+

ADDED   minimt/db.scm
Index: minimt/db.scm
==================================================================
--- /dev/null
+++ minimt/db.scm
@@ -0,0 +1,188 @@
+;; 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 .
+;;
+;; pretend to be a simplified Megatest
+
+(use sql-de-lite defstruct)
+
+;; init the db - NOTE: takes a db NOT a dbconn
+;;
+(define (init-db db)
+  (with-transaction
+   db
+   (lambda ()
+     (for-each
+      (lambda (qrystr)
+	(exec (sql db qrystr)))
+      '("CREATE TABLE IF NOT EXISTS runs 
+           (id        INTEGER PRIMARY KEY,
+            target    TEXT NOT NULL,
+            run_name  TEXT NOT NULL,
+            state     TEXT NOT NULL,
+            status    TEXT NOT NULL,
+            CONSTRAINT runs_constraint UNIQUE (run_name));"
+	"CREATE TABLE IF NOT EXISTS tests
+           (id        INTEGER PRIMARY KEY,
+            run_id    INTEGER NOT NULL,
+            test_name TEXT NOT NULL,
+            state     TEXT NOT NULL,
+            status    TEXT NOT NULL,
+            start_time INTEGER DEFAULT (strftime('%s','now')),
+            end_time   INTEGER DEFAULT -1,
+            CONSTRAINT tests_constraint UNIQUE (run_id,test_name));"
+	"CREATE TABLE IF NOT EXISTS steps
+           (id        INTEGER PRIMARY KEY,
+            test_id   INTEGER NOT NULL,
+            step_name  TEXT NOT NULL,
+            state     TEXT NOT NULL,
+            status    TEXT NOT NULL,
+            CONSTRAINT step_constraint UNIQUE (test_id,step_name));")))))
+
+(defstruct dbconn-dat
+  dbh       ;; the database handle
+  writeable ;; do we have write access?
+  path      ;; where the db lives
+  name      ;; name of the db
+  )
+
+;; open the database, return a dbconn struct
+(define (open-create-db path fname init)
+  (let* ((fullname       (conc path "/" fname))
+	 (already-exists (file-exists? fullname))
+	 (write-access   (and (file-write-access? path)
+			      (or (not already-exists)
+				  (and already-exists
+				       (file-write-access? fullname)))))
+	 (db             (if (or already-exists write-access)
+			     (open-database fullname)
+			     (begin
+			       (print "FATAL: No existing db and no write access thus cannot create " fullname)  ;; no db and no write access cannot proceed.
+			       (exit 1))))
+	 (dbconn         (make-dbconn-dat)))
+    (set-busy-handler! db (busy-timeout 120000)) ;; set a busy timeout
+    (exec (sql db "PRAGMA synchronous=0;"))
+    (if (and init write-access (not already-exists))
+	(init db))
+    (dbconn-dat-dbh-set!       dbconn db)
+    (dbconn-dat-writeable-set! dbconn write-access)
+    (dbconn-dat-path-set!      dbconn path)
+    (dbconn-dat-name-set!      dbconn fname)
+    dbconn))
+
+(define-inline (get-db dbconn)
+  (dbconn-dat-dbh dbconn))
+
+;; RUNS
+
+;; create a run
+(define (create-run dbconn target run-name)
+  (exec (sql (get-db dbconn) "INSERT INTO runs (run_name,target,state,status) VALUES (?,?,'NEW','na');")
+	run-name target))
+
+;; get a run id
+(define (get-run-id dbconn target run-name)
+  (first-column (query fetch (sql (get-db dbconn) "SELECT id FROM runs WHERE target=? AND run_name=?;")
+		       target run-name)))
+
+;; TESTS
+
+(defstruct test-dat
+  id
+  run-id
+  test-name
+  state
+  status)
+
+;; create a test
+(define (create-test dbconn run-id test-name)
+  (exec (sql (get-db dbconn) "INSERT INTO tests (run_id,test_name,state,status) VALUES (?,?,'NOT_STARTED','na');")
+	run-id test-name))
+
+;; get a test id
+(define (get-test-id dbconn run-id test-name)
+  (first-column (query fetch (sql (get-db dbconn) "SELECT id FROM tests WHERE run_id=? AND test_name=?;")
+		       run-id test-name)))
+
+(define-inline (test-row->test-dat row)
+    (make-test-dat
+     id:        (list-ref row 0)
+     run-id:    (list-ref row 1)
+     test-name: (list-ref row 2)
+     state:     (list-ref row 3)
+     status:    (list-ref row 4)))
+  
+;; get the data for given test-id
+(define (test-get-record dbconn test-id)
+  (let* ((row (query fetch-row (sql (get-db dbconn) "SELECT id,run_id,test_name,state,status FROM tests WHERE test_id=?;")
+		     test-id)))
+    (test-row->test-dat row)))
+
+;; get a bunch of tests data
+(define (test-get-tests dbconn run-ids test-name-patt)
+  (let* ((rows (query fetch-rows
+		      (sql (get-db dbconn)
+			   (conc "SELECT id,run_id,test_name,state,status FROM tests WHERE test_name LIKE ? AND run_id IN ("
+				 (string-intersperse (map conc run-ids) ",") ");"))
+		      test-name-patt)))
+    (map test-row->test-dat rows)))
+   
+(define (test-set-state-status dbconn test-id new-state new-status)
+  (exec (sql (get-db dbconn) "UPDATE tests SET state=?,status=?,end_time=? WHERE id=?;")
+	new-state new-status (current-seconds) test-id))
+
+;; STEPS
+
+;; create a step
+(define (create-step dbconn test-id step-name)
+  (exec (sql (get-db dbconn) "INSERT INTO steps (test_id,step_name,state,status) VALUES (?,?,'NOT_STARTED','na');")
+	test-id step-name))
+
+;; get a step id
+(define (get-step-id dbconn test-id step-name)
+  (first-column (query fetch (sql (get-db dbconn) "SELECT id FROM steps WHERE test_id=? AND step_name=?;")
+		       test-id step-name)))
+
+(define (step-set-state-status dbconn step-id new-state new-status)
+  (exec (sql (get-db dbconn) "UPDATE steps SET state=?,status=? WHERE id=?;")
+	new-state new-status step-id))
+
+;;======================================================================
+;; Statistics gathering
+;;======================================================================
+
+(define *stats* (make-hash-table))
+
+(define (update-stats key duration)
+  (let ((rec (or (hash-table-ref/default *stats* key #f)
+		 (let ((new (vector 0 0 0)))
+		   (hash-table-set! *stats* key new)
+		   new))))
+    (vector-set! rec 0 (+ (vector-ref rec 0) 1))        ;; num calls
+    (vector-set! rec 1 (+ (vector-ref rec 1) duration)) ;; total duration
+    (if (> duration (vector-ref rec 2) )
+	(vector-set! rec 2 duration))))
+
+(define (statwrap name proc)
+  (lambda params
+    (let ((start-time (current-milliseconds))
+	  (res        (apply proc params)))
+      (update-stats name (- (current-milliseconds) start-time))
+      res)))
+
+(define (print-stats statdat)
+  (hash-table-for-each
+   statdat
+   (lambda (key val)
+     (print key " count: " (vector-ref val 0) " avg: " (/ (vector-ref val 1)(vector-ref val 0)) " max: " (vector-ref val 2)))))

ADDED   minimt/direct.scm
Index: minimt/direct.scm
==================================================================
--- /dev/null
+++ minimt/direct.scm
@@ -0,0 +1,11 @@
+;; direct API, call the db calls directly
+(define rmt:create-run            (statwrap 'create-run  create-run))
+(define rmt:create-step           (statwrap 'create-step create-step))
+(define rmt:create-test           (statwrap 'create-test create-test))
+(define rmt:get-test-id           (statwrap 'get-test-id get-test-id))
+(define rmt:get-run-id            (statwrap 'get-run-id  get-run-id))
+(define rmt:open-create-db        (statwrap 'open        open-create-db))
+(define rmt:step-set-state-status (statwrap 'step-set-state-status step-set-state-status))
+(define rmt:test-set-state-status (statwrap 'test-set-state-status test-set-state-status))
+(define rmt:test-get-tests        (statwrap 'test-get-tests        test-get-tests))
+

ADDED   minimt/minimt.scm
Index: minimt/minimt.scm
==================================================================
--- /dev/null
+++ minimt/minimt.scm
@@ -0,0 +1,101 @@
+;; 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 posix)
+
+(include "db.scm")
+
+;; define following in setup.scm
+;;    *remotehost*  => host for "tests"
+;;    *homehost*    => host for servers
+;;    *homepath*    => directory from which to run
+;;    *numtests*    => how many tests to simulate for each run
+;;    *numruns*     => how many runs to simulate
+;;    
+(include "setup.scm")
+
+(include "direct.scm") ;; direct db calls
+
+;; RUN A TEST
+(define (run-test dbconn run-id test-name)
+  (rmt:create-test dbconn run-id test-name)
+  (let ((test-id (rmt:get-test-id dbconn run-id test-name)))
+    (rmt:test-set-state-status dbconn test-id "LAUNCHED" "na")
+    (thread-sleep! *launchdelay*)
+    (rmt:test-set-state-status dbconn test-id "RUNNING" "na")
+    (let loop ((step-num 0))
+      (let ((step-name (conc "step" step-num)))
+       (rmt:create-step dbconn test-id step-name)
+       (let ((step-id (get-step-id dbconn test-id step-name)))
+	 (rmt:step-set-state-status dbconn step-id "START" -1)
+	 (thread-sleep! *stepdelay*)
+	 (rmt:step-set-state-status dbconn step-id "END" 0)
+	 (print"   STEP: " step-name " done.")))
+      (if (< step-num *numsteps*)
+	  (loop (+ step-num 1))))
+    ;; we will do a large but bogus read to simulate the logic in Megatest
+    (rmt:test-get-tests dbconn `(,run-id) "%")
+    (rmt:test-set-state-status dbconn test-id "COMPLETED" (if (> (random 10) 2) "PASS" "FAIL"))
+    (print "TEST: " test-name " done.")
+    (print "Stats:")
+    (print-stats *stats*)
+    test-id))
+
+;; RUN A RUN
+(define (run-run dbconn target run-name num-tests)
+  (rmt:create-run dbconn target run-name)
+  (let ((run-id (rmt:get-run-id dbconn target run-name)))
+    (let loop ((test-num 0))
+      (system (conc "NBFAKE_LOG=test-" test-num "-run-id-" run-id ".log NBFAKE_HOST=" *remotehost* " nbfake minimt runtest " run-id " test-" test-num))
+      (if (< test-num num-tests)
+	  (loop (+ test-num 1))))))
+
+;; Do what is asked
+(let ((args (cdr (argv))))
+  (if (< (length args) 1)
+      (print
+       "Usage: minimt [options]" "
+  runtest run-id testname
+  runrun  target runname")
+      (let ((cmd    (car args))
+	    (dbconn (rmt:open-create-db *homepath* "mt.db" init-db)))
+	(thread-sleep! 0.5) ;; be sure the db is written out to disk? Should really not be needed.
+	(change-directory *homepath*)
+	(case (string->symbol cmd)
+	  ((runtest)
+	   (let ((run-id    (string->number (cadr args)))
+		 (test-name (caddr args)))
+	     (print "Launching test " test-name " for run-id " run-id)
+	     (run-test dbconn run-id test-name)))
+	  ((runrun)
+	   (let ((target   (cadr args))
+		 (run-name (caddr args)))
+	     (run-run dbconn target run-name *numtests*)
+	     (print "Use: sqlite3 runtest/mt.db 'select max(end_time)-min(start_time) from tests;' to see the total run time")
+	     ))
+	  ((runall)
+	   (for-each
+	    (lambda (target)
+	      (let loop ((run-num 0))
+		(thread-sleep! *rundelay*)
+		(system (conc "NBFAKE_LOG=run-" target "-" run-num ".log nbfake minimt runrun " target " run-" run-num))
+		(if (< run-num *numruns*)
+		    (loop (+ run-num 1)))))
+	    *targets*))
+	  ((server)
+	   (start-server dbconn))
+	  (else
+	   (print "Command: " cmd " not recognised. Run without params to see help.")))
+	(close-database (dbconn-dat-dbh dbconn)))))

ADDED   minimt/queued.scm
Index: minimt/queued.scm
==================================================================
--- /dev/null
+++ minimt/queued.scm
@@ -0,0 +1,209 @@
+
+(use nanomsg defstruct srfi-18)
+
+;;======================================================================
+;; Commands
+;;======================================================================
+
+(define *commands* (make-hash-table))
+
+(defstruct cmd
+  key
+  proc
+  ctype ;; command type; 'r (read), 'w (write) or 't (transaction)
+  )
+
+(define (register-command key ctype proc)
+  (hash-table-set! *commands*
+		   key
+		   (make-cmd key: key ctype: ctype proc: proc)))
+
+(define (get-proc key)
+  (cmd-proc (hash-table-ref key *commands*)))
+
+(for-each
+ (lambda (dat)
+   (apply register-command dat))
+ `( (create-run    w ,create-run)
+    (create-step   w ,create-step)
+    (create-test   w ,create-test)
+    (get-test-id   r ,get-test-id)
+    (get-run-id    r ,get-run-id)
+    ;; (open-db       w ,open-create-db)
+    (step-set-ss   w ,step-set-state-status)
+    (test-set-ss   w ,test-set-state-status)
+    (test-get-tests r ,test-get-tests) ))
+
+;;======================================================================
+;; Server/client stuff
+;;======================================================================
+
+(define-inline (encode data)
+  (with-output-to-string
+    (lambda ()
+      (write data))))
+
+(define-inline (decode data)
+  (with-input-from-string
+      data
+    (lambda ()
+      (read))))
+  
+;;======================================================================
+;; Command queue
+;;======================================================================
+
+(defstruct qitem
+  command
+  params
+  host-port)
+
+(define *cmd-queue* '())
+(define *queue-mutex* (make-mutex))
+
+(define (queue-push cmddat)
+  (mutex-lock! *queue-mutex*)
+  (set! *cmd-queue* (cons cmddat *cmd-queue*))
+  (mutex-unlock! *queue-mutex*))
+
+;; get all the cmds of type ctype and return them, also remove them from the queue
+(define (queue-take ctype)
+  (mutex-lock! *queue-mutex*)
+  (let ((res (filter (lambda (x)(eq? (cmd-ctype x) ctype))       *cmd-queue*))
+	(rem (filter (lambda (x)(not (eq? (cmd-ctype x) ctype))) *cmd-queue*)))
+    (set! *queue* rem)
+    (mutex-unlock! *queue-mutex*)
+    res))
+
+(define (queue-process-commands dbconn commands)
+  (for-each
+   (lambda (qitem)
+     (let ((soc (request-connect (qitem-host-port qitem))) ;; we will be sending the data back to host-port via soc
+	   (cmd (hash-table-ref/default *commands* (qitem-command qitem) #f)))
+       (if cmd
+	   (let* ((res (apply (get-proc cmd) dbconn (qitem-params qitem)))
+		  (pkg (encode `((r . ,res)))))
+	     (nn-send soc pkg)
+	     (if (not (eq? (nn-recv soc)) "ok")
+		 (print "Client failed to receive properly the data from " cmd " request"))))))
+   commands))
+
+;; the continuously running queue processor
+;;
+(define ((queue-processor dbconn))
+  (let loop ()
+    (queue-process-commands dbconn (queue-take 'r))  ;; reads first, probably largest numbers of them
+    (queue-process-commands dbconn (queue-take 'w))  ;; writes next
+    (queue-process-commands dbconn (queue-take 't))  ;; lastly process transactions
+    (thread-sleep! 0.2)                              ;; open up the db for any other processes to access
+    (loop)))
+
+;;======================================================================
+;; Client stuff
+;;======================================================================
+
+;; client struct
+(defstruct client
+  host-port
+  socket
+  last-access)
+
+(define *clients* (make-hash-table)) ;; host:port -> client struct
+(define *client-mutex* (make-mutex))
+
+;; add a channel or return existing channel, this is a normal req
+;; 
+(define (request-connect host-port)
+  (mutex-lock! *client-mutex*)
+  (let* ((curr (hash-table-ref/default *clients* host-port #f)))
+    (if curr
+	(begin
+	  (mutex-unlock! *client-mutex*)
+	  curr)
+	(let ((req (nn-socket 'req)))
+	  (nn-connect req host-port) ;; "inproc://test")
+	  (hash-table-set! *clients* host-port req)
+	  (mutex-unlock! *client-mutex*)
+	  req))))
+
+;; open up a channel to the server and send a package of info for the server to act on
+;; host-port needs to be found and provided
+;;
+(define (generic-db-access host-port)
+  (let* ((soc (request-connect host-port))
+	 ;; NEED *MY* host/port also to let the server know where to send the results
+	 )))
+    
+
+(define (client-send-receive soc msg)
+  (nn-send soc msg)
+  (nn-recv soc))
+  
+;;======================================================================
+;; Server
+;;======================================================================
+
+(defstruct srvdat
+  host
+  port
+  soc)
+
+;; remember, everyone starts a server, both client and the actual server alike.
+;; clients start a server for the server to return results to.
+;;
+(define (start-raw-server #!key (given-host-name #f))
+  (let ((srvdat    (let loop ((portnum 10000))
+		     (handle-exceptions
+			 exn
+			 (if (< portnum 64000)
+			     (loop (+ portnum 1))
+			     #f)
+		       (let* ((rep (nn-socket 'rep)))
+			 (nn-bind rep (conc "tcp://*:" portnum)) ;; "inproc://test")
+			 (make-srvdat port: portnum soc: rep)))))
+	(host-name (or give-host-name (get-host-name)))
+	(soc       (srvdat-soc srvdat)))
+    (srvdat-host-set! srvdat host-name)
+    srvdat))
+
+;; The actual *server* side server
+;;
+(define (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
+    (thread-start! (queue-processory 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: BAD request " dat))
+	    (loop (nn-recv soc)))))
+    (nn-close soc)))
+  
+;;======================================================================
+;; Gasket layer
+;;======================================================================
+
+(define rmt:open-create-db open-create-db)
+(define (rmt:create-run . params)
+  
+  

ADDED   minimt/setup.scm
Index: minimt/setup.scm
==================================================================
--- /dev/null
+++ minimt/setup.scm
@@ -0,0 +1,32 @@
+;; 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 *remotehost* "orion")
+(define *homehost*   "zeus")
+(define *homepath*   "/nfs/phoebe/disk1/home/mfs_matt/data/megatest/minimt/runtest")
+(define *numsteps*   20)
+(define *numtests*   20)
+(define *numruns*    5)
+(define *targets*    '("targ1"))
+(define *testdelay*  0)
+(define *rundelay*   0)
+(define *launchdelay* 0)
+(define *stepdelay*   0)
+
+(use trace)
+(trace-call-sites #t)
+(trace
+;;  open-create-db
+ )

Index: mlaunch.scm
==================================================================
--- mlaunch.scm
+++ mlaunch.scm
@@ -15,12 +15,11 @@
 ;;   take jobs from the given queue and keep launching them keeping
 ;;   the cpu load at the targeted level
 ;;
 ;;======================================================================
 
-(use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking format)
-(import (prefix sqlite3 sqlite3:))
+(use sqlite3 srfi-1 posix regex regex-case srfi-69 format)
 
 (declare (unit mlaunch))
 (declare (uses db))
 (declare (uses common))
 

Index: mockup-cached-writes.scm
==================================================================
--- mockup-cached-writes.scm
+++ mockup-cached-writes.scm
@@ -1,5 +1,20 @@
+;; 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 (make-cached-writer the-db)
   (let ((db    the-db)
 	(queue '()))

Index: mt-pg.sql
==================================================================
--- mt-pg.sql
+++ mt-pg.sql
@@ -1,11 +1,11 @@
 -- CREATE TABLE IF NOT EXISTS keys (
 --        id SERIAL PRIMARY KEY,
 --        fieldname TEXT,
 --        fieldtype TEXT,
 --        CONSTRAINT keyconstraint UNIQUE (fieldname));
-
+DROP VIEW IF EXISTS area_tag_view;
 DROP TABLE IF EXISTS areas;
 DROP TABLE IF EXISTS ttype;
 DROP TABLE IF EXISTS runs;
 DROP TABLE IF EXISTS run_stats;
 DROP TABLE IF EXISTS test_meta;
@@ -21,10 +21,18 @@
 DROP TABLE IF EXISTS test_data;
 DROP TABLE IF EXISTS test_rundat;
 DROP TABLE IF EXISTS archives;
 DROP TABLE IF EXISTS session_vars;
 DROP TABLE IF EXISTS sessions;
+DROP TABLE IF EXISTS tags;
+DROP TABLE IF EXISTS users; 
+DROP TABLE IF EXISTS webviews;
+DROP TABLE IF EXISTS area_tags;
+
+DROP TABLE IF EXISTS users_webviews;
+
+
 
 CREATE TABLE IF NOT EXISTS session_vars (
        id SERIAL PRIMARY KEY,
        session_id INTEGER,
        page TEXT,
@@ -41,10 +49,25 @@
        area_name TEXT NOT NULL,
        area_path TEXT NOT NULL,
        last_sync INTEGER DEFAULT 0,
        CONSTRAINT areaconstraint UNIQUE (area_name));
 
+CREATE TABLE IF NOT EXISTS tags (
+       id SERIAL PRIMARY KEY,
+       tag_name TEXT NOT NULL,
+       CONSTRAINT tagconstraint UNIQUE (tag_name));
+
+CREATE TABLE IF NOT EXISTS area_tags (
+       id SERIAL PRIMARY KEY,
+       tag_id   INTEGER DEFAULT 0,
+       area_id  INTEGER DEFAULT 0,
+       CONSTRAINT areatagconstraint UNIQUE (tag_id, area_id));
+
+CREATE VIEW area_tag_view as 
+select a.id as aid, t.id as tid,area_name,tag_name from areas as a inner join area_tags as at on at.area_id = a.id
+inner join tags as t on t.id = at.tag_id  ;
+
 INSERT INTO areas (id,area_name,area_path) VALUES (0,'local','.');
 
 CREATE TABLE IF NOT EXISTS ttype (
        id SERIAL PRIMARY KEY,
        target_spec TEXT DEFAULT '');
@@ -61,11 +84,11 @@
        comment    TEXT DEFAULT '',
        fail_count INTEGER DEFAULT 0,
        pass_count INTEGER DEFAULT 0,
        last_update INTEGER DEFAULT extract(epoch from now()),
        area_id     INTEGER DEFAULT 0,
-       CONSTRAINT runsconstraint UNIQUE (target,ttype_id,run_name));
+       CONSTRAINT runsconstraint UNIQUE (target,ttype_id,run_name, area_id));
 
 CREATE TABLE IF NOT EXISTS run_stats (
        id     SERIAL PRIMARY KEY,
        run_id INTEGER,
        state  TEXT,
@@ -208,9 +231,84 @@
        status       TEXT DEFAULT 'n/a',
        archive_type TEXT DEFAULT 'bup',
        du           INTEGER,
        archive_path TEXT);
  
+CREATE TABLE IF NOT EXISTS users(
+   id SERIAL  PRIMARY KEY   ,
+   username           TEXT    NOT NULL,
+   fullname          TEXT    NOT NULL, 
+   email             TEXT    NOT NULL, 
+   default_view      TEXT    default '',
+   deleted           INTEGER     default 0
+);
+
+CREATE TABLE IF NOT EXISTS base_paths(
+   id SERIAL  PRIMARY KEY   ,
+   path           TEXT    NOT NULL,
+   deleted           INTEGER     default 0
+);
+
+
+CREATE TABLE IF NOT EXISTS area_owners(
+   id SERIAL  PRIMARY KEY   ,
+   user_id INTEGER,
+   base_path_id INTEGER,
+	 deleted           INTEGER     default 0
+);
+
+CREATE TABLE IF NOT EXISTS shared_user_views(
+   id SERIAL  PRIMARY KEY   ,
+   user_id INTEGER,
+   view_id INTEGER,
+	 deleted           INTEGER     default 0
+);
+
+ 
+CREATE TABLE IF NOT EXISTS webviews(
+   id SERIAL  PRIMARY KEY   ,
+   owner_id          INTEGER NOT NULL,
+   name              TEXT    NOT NULL, 
+   ttype_id          INTEGER DEFAULT 0,
+   view_specifics    TEXT   ,
+   col               TEXT    NOT NULL,
+   row               TEXT    NOT NULL,
+   public            INTEGER DEFAULT 0,
+   deleted           INTEGER     default 0
+);
+
+
+
+CREATE TABLE IF NOT EXISTS users_webviews(
+ id      SERIAL  PRIMARY KEY   ,
+ user_id   INTEGER NOT NULL,
+ webview_id  INTEGER NOT NULL,
+ deleted     INTEGER default 0,
+ searchpattern TEXT Default '',
+ web_page TEXT Default '',
+ other_search_data TEXT Default ''
+);
+
+CREATE TABLE IF NOT EXISTS cctrl_info(
+ id      SERIAL  PRIMARY KEY   ,
+ user_id   INTEGER NOT NULL,
+ input TEXT Default '',
+ result_file TEXT Default NULL,
+ chksum TEXT
+);
+
+CREATE TABLE IF NOT EXISTS cctrl_config(
+	id      SERIAL  PRIMARY KEY   ,
+  area_type Text,
+  cmd TEXT 
+);
+
+CREATE TABLE IF NOT EXISTS platforms(
+	id      SERIAL  PRIMARY KEY   ,
+  name Text
+);
+
+
 
 -- TRUNCATE archive_blocks, archive_allocations, extradat, metadat,
 -- access_log, tests, test_steps, test_data, test_rundat, archives, runs,
 -- run_stats, test_meta, tasks_queue, archive_disks;

Index: mt.scm
==================================================================
--- mt.scm
+++ mt.scm
@@ -1,13 +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 sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking (srfi 18) posix-extras directory-utils call-with-environment-variables)
 (import (prefix sqlite3 sqlite3:))
 
@@ -127,47 +136,103 @@
 			  (cons testn res)))))))))
 
 ;;======================================================================
 ;;  T R I G G E R S
 ;;======================================================================
+
+(define (mt:run-trigger cmd test-id test-rundir trigger logname test-name item-path event-time actual-state actual-status)
+  ;; Putting the commandline into ( )'s means no control over the shell. 
+  ;; stdout and stderr will be caught in the NBFAKE or mt_launch.log files
+  ;; or equivalent. No need to do this. Just run it?
+  (let* ((fullcmd (conc "nbfake "
+			cmd           " "
+			test-id       " "
+			test-rundir   " "
+			trigger       " "
+			test-name     " "
+			item-path     " " ;; has / prepended to deal with toplevel tests
+			actual-state  " "
+			actual-status " "
+			event-time
+			))
+	 (prev-nbfake-log (get-environment-variable "NBFAKE_LOG")))
+    (setenv "NBFAKE_LOG" (conc (cond
+				((and (directory-exists? test-rundir)
+				      (file-write-access? test-rundir))
+				 test-rundir)
+				((and (directory-exists? *toppath*)
+				      (file-write-access? *toppath*))
+				 *toppath*)
+				(else (conc "/tmp/" (current-user-name))))
+			       "/" logname))
+    (debug:print-info 0 *default-log-port* "TRIGGERED on " trigger ", running command " fullcmd " output at " (get-environment-variable "NBFAKE_LOG"))
+    ;; (call-with-environment-variables
+    ;;  `(("NBFAKE_LOG" . ,(conc test-rundir "/" logname)))
+    ;;  (lambda ()
+    (process-run fullcmd)
+    (if prev-nbfake-log
+	(setenv "NBFAKE_LOG" prev-nbfake-log)
+	(unsetenv "NBFAKE_LOG"))
+    )) ;; ))
 
 (define (mt:process-triggers dbstruct run-id test-id newstate newstatus)
-  (let* ((test-dat      (db:get-test-info-by-id dbstruct run-id test-id)))
-    (if test-dat
-	(let* ((test-rundir   ;; (rmt:sdb-qry 'getstr ;; (filedb:get-path *fdb*
-		(db:test-get-rundir test-dat)) ;; ) ;; )
-	       (test-name     (db:test-get-testname test-dat))
-	       (tconfig       #f)
-	       (state         (if newstate  newstate  (db:test-get-state  test-dat)))
-	       (status        (if newstatus newstatus (db:test-get-status test-dat))))
-	  (if (and test-name
-		   test-rundir   ;; #f means no dir set yet
-		   (file-exists? test-rundir)
-		   (directory? test-rundir))
-	      (call-with-environment-variables
-	       (list (cons "MT_TEST_NAME" test-name)
-		     (cons "MT_TEST_RUN_DIR" test-rundir)
-		     (cons "MT_ITEMPATH"     (db:test-get-item-path test-dat)))
-	       (lambda ()
-		 (push-directory test-rundir)
-		 (set! tconfig (mt:lazy-read-test-config test-name))
-		 (for-each (lambda (trigger)
-			     (let ((cmd  (configf:lookup tconfig "triggers" trigger))
-				   (logf (conc  test-rundir "/last-trigger.log")))
-			       (if cmd
-				   ;; Putting the commandline into ( )'s means no control over the shell. 
-				   ;; stdout and stderr will be caught in the NBFAKE or mt_launch.log files
-				   ;; or equivalent. No need to do this. Just run it?
-				   (let ((fullcmd (conc cmd " " test-id " " test-rundir " " trigger "&")))
-				     (debug:print-info 0 *default-log-port* "TRIGGERED on " trigger ", running command " fullcmd)
-				     (process-run fullcmd)))))
-			   (list
-			    (conc state "/" status)
-			    (conc state "/")
-			    (conc "/" status)))
-		 (pop-directory))
-	       ))))))
+  (if test-id 
+      (let* ((test-dat      (db:get-test-info-by-id dbstruct run-id test-id)))
+	(if test-dat
+	    (let* ((test-rundir   (db:test-get-rundir       test-dat)) ;; ) ;; )
+		   (test-name     (db:test-get-testname     test-dat))
+		   (item-path     (db:test-get-item-path    test-dat))
+		   (duration      (db:test-get-run_duration test-dat))
+		   (comment       (db:test-get-comment      test-dat))
+		   (event-time    (db:test-get-event_time   test-dat))
+		   (tconfig       #f)
+		   (state         (if newstate  newstate  (db:test-get-state  test-dat)))
+		   (status        (if newstatus newstatus (db:test-get-status test-dat))))
+	      ;; (mutex-lock! *triggers-mutex*)
+              (handle-exceptions
+               exn
+               (begin
+                 (debug:print-error 0 *default-log-port* " Exception in mt:process-triggers for run-id="run-id" test-id="test-id" newstate="newstate" newstatus="newstatus
+                                    "\n   error: " ((condition-property-accessor 'exn 'message) exn)
+                                    "\n   test-rundir="test-rundir
+                                    "\n   test-name="test-name
+                                    "\n   item-path="item-path
+                                    "\n   state="state
+                                    "\n   status="status
+                                    "\n")
+                 (print-call-chain (current-error-port))
+                 #f)
+               (if (and test-name
+                        test-rundir)   ;; #f means no dir set yet
+                   ;; (common:file-exists? test-rundir)
+                   ;; (directory? test-rundir))
+                   (call-with-environment-variables
+                    (list (cons "MT_TEST_NAME"    (or test-name "no such test"))
+                          (cons "MT_TEST_RUN_DIR" (or test-rundir "no test directory yet"))
+                          (cons "MT_ITEMPATH"     (or item-path "")))
+                    (lambda ()
+                      (if (directory-exists? test-rundir)
+                          (push-directory test-rundir)
+                          (push-directory *toppath*))
+                      (set! tconfig (mt:lazy-read-test-config test-name))
+                      (for-each (lambda (trigger)
+                                  (let* ((munged-trigger (string-translate trigger "/ " "--"))
+					(logname        (conc "last-trigger-" munged-trigger ".log")))
+                                    ;; first any triggers from the testconfig
+                                    (let ((cmd  (configf:lookup tconfig "triggers" trigger)))
+                                      (if cmd (mt:run-trigger cmd test-id test-rundir trigger (conc "tconfig-" logname) test-name item-path event-time state status)))
+                                    ;; next any triggers from megatest.config
+                                    (let ((cmd  (configf:lookup *configdat* "triggers" trigger)))
+                                      (if cmd (mt:run-trigger cmd test-id test-rundir trigger (conc "mtconfig-" logname) test-name item-path event-time state status)))))
+                                (list
+                                 (conc state "/" status)
+                                 (conc state "/")
+                                 (conc "/" status)))
+		     (pop-directory))
+                    )))
+	      ;; (mutex-unlock! *triggers-mutex*)
+	      )))))
 
 ;;======================================================================
 ;;  S T A T E   A N D   S T A T U S   F O R   T E S T S 
 ;;======================================================================
 
@@ -206,11 +271,11 @@
 	(let ((test-dirs (tests:get-tests-search-path *configdat*)))
 	  (let loop ((hed (car test-dirs))
 		     (tal (cdr test-dirs)))
 	    ;; Setting MT_LINKTREE here is almost certainly unnecessary. 
 	    (let ((tconfig-file (conc hed "/" test-name "/testconfig")))
-	      (if (and (file-exists? tconfig-file)
+	      (if (and (common:file-exists? tconfig-file)
 		       (file-read-access? tconfig-file))
 		  (let ((link-tree-path (common:get-linktree)) ;; (configf:lookup *configdat* "setup" "linktree"))
 			(old-link-tree  (get-environment-variable "MT_LINKTREE")))
 		    (if link-tree-path (setenv "MT_LINKTREE" link-tree-path))
 		    (let ((newtcfg (read-config tconfig-file #f #f))) ;; NOTE: Does NOT run [system ...]

Index: mtut.scm
==================================================================
--- mtut.scm
+++ mtut.scm
@@ -1,23 +1,33 @@
-;; Copyright 2006-2017, 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-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 "common.scm")
 ;; (include "megatest-version.scm")
 
 ;; fake out readline usage of toplevel-command
 (define (toplevel-command . a) #f)
 
 (use srfi-1 posix srfi-69 readline ;;  regex regex-case srfi-69 apropos json http-client directory-utils rpc typed-records;; (srfi 18) extras)
-     srfi-18 extras format pkts pkts regex regex-case
-     (prefix dbi dbi:)) ;;  zmq extras)
+     srfi-18 extras format pkts regex regex-case
+     (prefix dbi dbi:)
+     nanomsg)
 
 (declare (uses common))
 (declare (uses megatest-version))
 (declare (uses margs))
 (declare (uses configf))
@@ -25,26 +35,71 @@
 
 (include "megatest-fossil-hash.scm")
 
 (require-library stml)
 
-(define *target-mappers*  (make-hash-table)) ;; '())
-(define *runname-mappers* (make-hash-table)) ;; '())
+;; stuff for the mapper and checker functions
+;;
+(define *target-mappers*  (make-hash-table)) 
+(define *runname-mappers* (make-hash-table)) 
+(define *area-checkers*   (make-hash-table)) 
 
+;; helpers for mappers/checkers
+(define (add-target-mapper name proc)
+  (hash-table-set! *target-mappers* name proc))
+(define (add-runname-mapper name proc)
+  (hash-table-set! *runname-mappers* name proc))
+(define (add-area-checker name proc)
+  (hash-table-set! *area-checkers* name proc))
+
+;; given a runkey, xlatr-key and other info return one of the following:
+;;   list of targets, null list to skip processing
+;;   
+(define (map-targets mtconf aval-alist runkey area contour #!key (xlatr-key-in #f))
+  (let* ((xlatr-key (or xlatr-key-in
+                        (conf-get/default mtconf aval-alist 'targtrans)))
+         (proc      (hash-table-ref/default *target-mappers* xlatr-key #f)))
+    (if proc
+        (begin
+          (print "Using target mapper: " xlatr-key)
+          (handle-exceptions
+           exn
+           (begin
+             (print "FAILED TO RUN TARGET MAPPER FOR " area ", called " xlatr-key)
+             (print "   function is: " (hash-table-ref/default *target-mappers* xlatr-key #f ) )
+             (print " message: " ((condition-property-accessor 'exn 'message) exn))
+             runkey)
+           (proc runkey area contour)))
+        (begin
+          (if xlatr-key 
+              (print "ERROR: Failed to find named target translator " xlatr-key ", using original target."))
+          `(,runkey))))) ;; no proc then use runkey
+
+;; given mtconf and areaconf extract a translator/filter, first look at areaconf
+;; then if not found look at default
+;;
+(define (conf-get/default mtconf areaconf keyname #!key (default #f))
+  (let ((res (or (alist-ref keyname areaconf)
+                 (configf:lookup mtconf "default" (conc keyname))
+                 default)))
+    (if res
+        (string->symbol res)
+        res)))
+  
 ;; this needs some thought regarding security implications.
 ;;
 ;;   i. Check that owner of the file and calling user are same?
 ;;  ii. Check that we are in a legal megatest area?
 ;; iii. Have some form of authentication or record of the md5sum or similar of the file?
 ;;  iv. Use compiled version in preference to .scm version. Thus there is a manual "blessing"
 ;;      required to use .mtutil.scm.
 ;;
-(if (file-exists? "megatest.config")
-    (if (file-exists? ".mtutil.so")
+(if (common:file-exists? "megatest.config")
+    (if (common:file-exists? ".mtutil.so")
 	(load ".mtutil.so")
-	(if (file-exists? ".mtutil.scm")
-	(load ".mtutil.scm"))))
+	(if (common:file-exists? ".mtutil.scm")
+            (load ".mtutil.scm"))))
 
 ;; Disabled help items
 ;;  -rollup                 : (currently disabled) fill run (set by :runname)  with latest test(s)
 ;;                            from prior runs with same keys
 ;; Contour actions
@@ -56,55 +111,61 @@
 mtutil, part of the Megatest tool suite, documentation at http://www.kiatoa.com/fossils/megatest
   version " megatest-version "
   license GPL, Copyright Matt Welland 2006-2017
 
 Usage: mtutil action [options]
-  -h                       : this help
-  -manual                  : show the Megatest user manual
-  -version                 : print megatest version (currently " megatest-version ")
-
-Actions:
-   run                     : initiate runs
-   remove                  : remove runs
-   rerun                   : register action for processing
-   set-ss                  : set state/status
-   archive                 : compress and move test data to archive disk
-   kill                    : stop tests or entire runs
-   db                      : database utilities
+  -h                         : this help
+  -manual                    : show the Megatest user manual
+  -version                   : print megatest version (currently " megatest-version ")
+			     
+Actions:		     
+   run                       : initiate runs
+   remove                    : remove runs
+   rerun                     : register action for processing
+   set-ss                    : set state/status
+   archive                   : compress and move test data to archive disk
+   kill                      : stop tests or entire runs
+   db                        : database utilities
+   areas, contours, setup    : show areas, contours or setup section from megatest.config
+   gendot                    : generate a graphviz dot file from pkts.
 
 Contour actions:
-   process                 : runs import, rungen and dispatch 
-
-Selectors 
-  -immediate               : apply this action immediately, default is to queue up actions
-  -area areapatt1,area2... : apply this action only to the specified areas
-  -target key1/key2/...    : run for key1, key2, etc.
-  -test-patt p1/p2,p3/...  : % is wildcard
-  -run-name                : required, name for this particular test run
-  -contour contourname     : run all targets for contourname, requires -run-name, -target
-  -state-status c/p,c/f    : Specify a list of state and status patterns
-  -tag-expr tag1,tag2%,..  : select tests with tags matching expression
-  -mode-patt key           : load testpatt from  in runconfigs instead of default TESTPATT
-                             if -testpatt and -tagexpr are not specified
-  -new state/status        : specify new state/status for set-ss
-
-Misc 
-  -start-dir path          : switch to this directory before running mtutil
-  -set-vars V1=1,V2=2      : Add environment variables to a run NB// these are
-                                 overwritten by values set in config files.
-  -log logfile             : send stdout and stderr to logfile
-  -repl                    : start a repl (useful for extending megatest)
-  -load file.scm           : load and run file.scm
-  -debug N|N,M,O...        : enable debug messages 0-N or N and M and O ...
-
-Utility
- db pgschema               : emit postgresql schema; do \"mtutil db pgschema | psql -d mydb\"
+   process                   : runs import, rungen and dispatch 
+			     
+Trigger propagation actions:
+   tsend a=b,c=d...          : send trigger info to all recpients in the [listeners] section
+   tlisten -port N           : listen for trigger info on port N
+			     
+Selectors 		     
+  -immediate                 : apply this action immediately, default is to queue up actions
+  -area areapatt1,area2...   : apply this action only to the specified areas
+  -target key1/key2/...      : run for key1, key2, etc.
+  -test-patt p1/p2,p3/...    : % is wildcard
+  -run-name                  : required, name for this particular test run
+  -contour contourname       : run all targets for contourname, requires -run-name, -target
+  -state-status c/p,c/f      : Specify a list of state and status patterns
+  -tag-expr tag1,tag2%,..    : select tests with tags matching expression
+  -mode-patt key             : load testpatt from  in runconfigs instead of default TESTPATT
+                               if -testpatt and -tagexpr are not specified
+  -new state/status          : specify new state/status for set-ss
+			     
+Misc 			     
+  -start-dir path            : switch to this directory before running mtutil
+  -set-vars V1=1,V2=2        : Add environment variables to a run NB// these are
+                                   overwritten by values set in config files.
+  -log logfile               : send stdout and stderr to logfile
+  -repl                      : start a repl (useful for extending megatest)
+  -load file.scm             : load and run file.scm
+  -debug N|N,M,O...          : enable debug messages 0-N or N and M and O ...
+			     
+Utility			     
+ db pgschema                 : emit postgresql schema; do \"mtutil db pgschema | psql -d mydb\"
 
 Examples:
 
 # Start a megatest run in the area \"mytests\"
-mtutil -area mytests -action run -target v1.63/aa3e -mode-patt MYPATT -tag-expr quick
+mtutil run -area mytests -target v1.63/aa3e -mode-patt MYPATT -tag-expr quick
 
 # Start a contour
 mtutil run -contour quick -target v1.63/aa3e 
 
 Called as " (string-intersperse (argv) " ") "
@@ -111,17 +172,20 @@
 Version " megatest-version ", built from " megatest-fossil-hash ))
 
 ;; args and pkt key specs
 ;;
 (define *arg-keys*
+  ;; used keys
+  ;;    a  - action
   '(
     ("-area"            . G) ;; maps to group
     ("-contour"         . c)
     ("-append-config"   . d)
     ("-state"           . e)
     ("-item-patt"       . i)
     ("-sync-to"         . k)
+    ("-new"             . l) ;; l (see below) is new-ss
     ("-run-name"        . n)
     ("-mode-patt"       . o)
     ("-test-patt"       . p)  ;; idea, enhance margs ("-test-patt" "-testpatt") => yields one value in "-test-patt"
     ("-status"          . s)
     ("-target"          . t)
@@ -131,10 +195,11 @@
     ("-load"            . #f)  ;; load and exectute a scheme file
     ("-log"             . #f)
     ("-msg"             . M)
     ("-start-dir"       . S)
     ("-set-vars"        . v)
+    ("-config"          . h)
     ))
 (define *switch-keys*
   '(
     ("-h"               . #f)
     ("-help"            . #f)
@@ -152,11 +217,42 @@
 ;; alist to map actions to old megatest commands
 (define *action-keys*
   '((run         . "-run")
     (sync        . "")
     (archive     . "-archive")
-    (set-ss      . "-set-state-status")))
+    (set-ss      . "-set-state-status")
+    (remove      . "-remove-runs")))
+
+;; Card types:
+;;
+;; A action
+;; U username (Unix)
+;; D timestamp
+;; T card type
+
+;; a summary list of used card types for helping to not accidentally re-use them
+;;
+;; ADGIMSTUZabcdefghiklnoprstuvwx
+
+;; utilitarian alist for standard cards
+;;
+(define *additional-cards*
+  '(
+    ;; Standard Cards
+    (A  . action    )
+    (D  . timestamp )
+    (T  . cardtype  )
+    (U  . user      ) ;; username
+    (Z  . shar1sum  )
+
+    ;; Extras
+    (a  . runkey    ) ;; needed for matching up pkts with target derived from runkey
+    ;; (l  . new-ss    ) ;; new state/status
+    (b  . branch    ) ;; repository branch or tag (fossil or git)
+    (f  . url       ) ;; repository URL (e.g. fossil or git)
+    (g  . clone     ) ;; existing clone area (cached in /tmp)
+    ))
 
 ;; inlst is an alternative input
 ;;
 (define (lookup-param-by-key key #!key (inlst #f))
   (fold (lambda (a res)
@@ -173,31 +269,16 @@
 ;;  U T I L S
 ;;======================================================================
 
 ;; given a mtutil param, return the old megatest equivalent
 ;;
-(define (param-translate param)
-  (or (alist-ref (string->symbol param)
-		 '((-tag-expr  . "-tagexpr")
-		   (-mode-patt . "--modepatt")
-		   (-run-name  . "-runname")
-		   (-test-patt . "-testpatt")
-		   (-msg       . "-m")))
-      param))
-
-(define (val->alist val)
-  (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)) . ,(cadr f)))
-		   (else f))))
-	     val-list)
-	'())))
+(define (megatest-param->mtutil-param param)
+  (let* ((mapping-alist (common:get-param-mapping flavor: 'switch-symbol)))
+    (alist-ref (string->symbol param) mapping-alist eq? param)
+    param))
+
+(define val->alist common:val->alist)
 
 (define (push-run-spec torun contour runkey spec)
   (configf:section-var-set! torun contour runkey
 			    (cons spec
 				  (or (configf:lookup torun contour runkey)
@@ -210,11 +291,11 @@
 	(print "ERROR: failed to create directory " dest-dir " message: " ((condition-property-accessor 'exn 'message) exn))
       (create-directory dest-dir #t))
     (handle-exceptions
 	exn
 	(print "ERROR: failed to clone or sync 1ossil " url " message: " ((condition-property-accessor 'exn 'message) exn))
-      (if (file-exists? targ-file)
+      (if (common:file-exists? targ-file)
 	  (system (conc "fossil pull --once " url " -R " targ-file))
 	  (system (conc "fossil clone " url " " targ-file))
 	  ))))
 
 (define (fossil:last-change-node-and-time fossils-dir fossil-name branch)
@@ -259,22 +340,14 @@
 	   (loop (get-line) date node time))))
        (else ;; no more datat and last node on branch not found
 	(close-input-port timeline-port)
 	(values  (common:date-time->seconds (conc date " " time)) node))))))
 
-
 ;;======================================================================
 ;; GLOBALS
 ;;======================================================================
 
-;; Card types:
-;;
-;; a action
-;; u username (Unix)
-;; D timestamp
-;; T card type
-
 ;; process args
 (define *action* (if (> (length (argv)) 1)
 		     (cadr (argv))
 		     #f))
 (define remargs (args:get-args 
@@ -300,11 +373,12 @@
 (if (and (not (null? remargs))
 	 (not (or
 	       (args:get-arg "-runstep")
 	       (args:get-arg "-envcap")
 	       (args:get-arg "-envdelta")
-	       (member *action* '("db"))   ;; very loose checks on db.
+	       (member *action* '("db" "tsend" "tlisten"))   ;; very loose checks on db and tsend/listen
+	       (equal? *action* "show")    ;; just keep going if list
 	       )))
     (debug:print-error 0 *default-log-port* "Unrecognised arguments: " (string-intersperse (if (list? remargs) remargs (argv))  " ")))
 
 (if (or (args:any? "-h" "help" "-help" "--help")
 	(member *action* '("-h" "-help" "--help" "help")))
@@ -311,69 +385,80 @@
     (begin
       (print help)
       (exit 1)))
 
 ;;======================================================================
-;; pkts
+;; Nanomsg transport
 ;;======================================================================
 
-(define (with-queue-db mtconf proc)
-  (let* ((pktsdirs (configf:lookup mtconf "setup"  "pktsdirs"))
-	 (pktsdir  (if pktsdirs (car (string-split pktsdirs " ")) #f))
-	 (toppath  (configf:lookup mtconf "dyndat" "toppath"))
-	 (pdbpath  (or (configf:lookup mtconf "setup"  "pdbpath") pktsdir)))
-    (if (not (and  pktsdir toppath pdbpath))
-	(begin
-	  (print "ERROR: settings are missing in your megatest.config for area management.")
-	  (print "  you need to have pktsdir in the [setup] section."))
-	(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 (load-pkts-to-db mtconf)
-  (with-queue-db
-   mtconf
-   (lambda (pktsdirs pktsdir pdb)
-     (for-each
-      (lambda (pktsdir) ;; look at all
-	(if (and (file-exists? pktsdir)
-		 (directory? pktsdir)
-		 (file-read-access? 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))))
-      (string-split pktsdirs)))))
-
-(define (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 (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
+(define-inline (encode data)
+  (with-output-to-string
+    (lambda ()
+      (write data))))
+
+(define-inline (decode data)
+  (with-input-from-string
+      data
+    (lambda ()
+      (read))))
+
+(define (is-port-in-use port-num)
+ (let* ((ret #f))
+     (let-values (((inp oup pid)
+                (process "netstat" (list  "-tulpn" ))))
+      (let loop ((inl (read-line inp)))
+        (if (not (eof-object? inl))
+            (begin 
+                (if (string-search (regexp (conc ":" port-num)) inl)
+                 (begin
+                 ;(print "Output: "  inl)
+                  (set! ret  #t))
+                 (loop (read-line inp)))))))
+ret))
+
+;;start a server, returns the connection
+;;
+(define (start-nn-server portnum )
+  (let ((rep (nn-socket 'rep)))
+    (handle-exceptions
+     exn
+     (let ((emsg ((condition-property-accessor 'exn 'message) exn)))
+       (print "ERROR: Failed to start server \"" emsg "\"")
+       (exit 1))
+      
+     (nn-bind rep (conc "tcp://*:" portnum)))
+    rep))
+
+;; open connection to server, send message, close connection
+;;
+(define (open-send-close-nn host-port msg #!key (timeout 3)) ;; default timeout is 3 seconds
+  (let ((req  (nn-socket 'req))
+        (uri  (conc "tcp://" host-port))
+        (res  #f)) 
+    (handle-exceptions
+     exn
+     (let ((emsg ((condition-property-accessor 'exn 'message) exn)))
+       (print "ERROR: Failed to connect/send to " uri " message was \"" emsg "\"")
+       #f)
+     (nn-connect req uri)
+     (nn-send req msg)
+     ;; NEED timer here!
+     (let* ((th1  (make-thread (lambda ()
+                                 (let ((resp (nn-recv req)))
+                                   (nn-close req)
+                                   (set! res (if (equal? resp "ok")
+                                                 #t
+                                                 #f))))
+                               "recv thread"))
+            (th2 (make-thread (lambda ()
+                                (thread-sleep! timeout)
+                                (thread-terminate! th1))
+                             "timer thread")))
+       (thread-start! th1)
+       (thread-start! th2)
+       (thread-join! th1)
+       res))))
 
 ;;======================================================================
 ;; Runs
 ;;======================================================================
 
@@ -386,24 +471,34 @@
 ;; collect, translate, collate and assemble a pkt from the command-line
 ;;
 ;; sched => force the run start time to be recorded as sched Unix
 ;; epoch. This aligns times properly for triggers in some cases.
 ;;
-(define (command-line->pkt action args-alist sched-in)
+;;  extra-dat format is ( 'x xval 'y yval .... )
+;;
+(define (command-line->pkt action args-alist sched-in #!key (extra-dat '())(area-path #f)(new-ss #f))
   (let* ((sched     (cond
 		     ((vector? sched-in)(local-time->seconds sched-in)) ;; we recieved a time
 		     ((number? sched-in) sched-in)
 		     (else     (current-seconds))))
 	 (args-data (if args-alist
 			(if (hash-table? args-alist) ;; seriously?
 			    (hash-table->alist args-alist)
 			    args-alist)
 			(hash-table->alist args:arg-hash))) ;; if no args-alist then we assume this is a call driven directly by commandline
-	 (alldat    (apply append (list 'T "cmd"
-					'a action
-					'U (current-user-name)
-					'D sched)
+	 (alldat    (apply append
+			   (list 'A action
+				 'U (current-user-name)
+				 'D sched)
+			   (if area-path
+			       (list 'S area-path) ;; the area-path is mapped to the start-dir
+			       '())
+                           (if (list? extra-dat)
+			       extra-dat
+			       (begin
+				 (debug:print 0 *default-log-port* "ERROR: command-line->pkt received bad extra-dat " extra-dat)
+				 '()))
 			   (map (lambda (x)
 				  (let* ((param (car x))
 					 (value (cdr x))
 					 (pmeta (assoc param *arg-keys*))    ;; translate the card key to a megatest switch or parameter
 					 (smeta (assoc param *switch-keys*)) ;; first lookup the key in arg-keys or switch-keys
@@ -412,12 +507,12 @@
 						    #f)))
 				    (if (or pmeta smeta)                     ;; construct the switch/param pair.
 					(list meta value)
 					'())))
 				(filter cdr args-data)))))
-;; (print  "Alldat: " alldat
-;;         " args-data: " args-data)
+    (print  "Alldat: " alldat
+	    " args-data: " args-data)
     (add-z-card
      (apply construct-sdat alldat))))
 
 (define (simple-setup start-dir-in)
   (let* ((start-dir (or start-dir-in "."))
@@ -427,15 +522,15 @@
 		     ;; environ-patt: "env-override"
 		     given-toppath: start-dir
 		     ;; pathenvvar: "MT_RUN_AREA_HOME"
 		     ))
 	 (mtconf    (if mtconfdat (car mtconfdat) #f)))
-    ;; we set some dynamic data in a section called "dyndata"
+    ;; we set some dynamic data in a section called "scratchdata"
     (if mtconf
 	(begin
-	  (configf:section-var-set! mtconf "dyndat" "toppath" start-dir)))
-    ;; (print "TOPPATH: " (configf:lookup mtconf "dyndat" "toppath"))
+	  (configf:section-var-set! mtconf "scratchdat" "toppath" start-dir)))
+    ;; (print "TOPPATH: " (configf:lookup mtconf "scratchdat" "toppath"))
     mtconfdat))
 
 
 ;; NEED TIMESTAMP ON PKTS for efficient loading of packets into db.
 
@@ -446,16 +541,19 @@
 ;;  ii. Pass the pkt keys and values to this proc and go from there.
 ;; iii. Maybe have an abstraction alist with meaningful names for the pkt keys
 ;;
 ;; Override the run start time record with sched. Usually #f is fine.
 ;; 
-(define (create-run-pkt mtconf action area runkey runname mode-patt tag-expr pktsdir reason contour sched dbdest append-conf runtrans)
+(define (create-run-pkt mtconf action area runkey target runname mode-patt 
+                        tag-expr pktsdir reason contour sched dbdest append-conf
+                        runtrans)
   (let* ((good-val   (lambda (inval)(and inval (string? inval)(not (string-null? inval)))))
-	 (area-dat   (val->alist (or (configf:lookup mtconf "areas" area) "")))
+	 (area-dat   (common:val->alist (or (configf:lookup mtconf "areas" area) "")))
 	 (area-path  (alist-ref 'path      area-dat))
-	 (area-xlatr (alist-ref 'targtrans area-dat))
-	 (new-runname (let* ((callname (if (string? runtrans)(string->symbol runtrans) #f))
+	 ;; (area-xlatr (alist-ref 'targtrans area-dat))
+         ;; (xlatr-key  (if area-xlatr (string->symbol area-xlatr) #f))
+         (new-runname (let* ((callname (if (string? runtrans)(string->symbol runtrans) #f))
 			     (mapper   (if callname (hash-table-ref/default *runname-mappers* callname #f) #f)))
 			;; (print "callname=" callname " runtrans=" runtrans " mapper=" mapper)
 			(if (and callname
 				 (not (equal? callname "auto"))
 				 (not mapper))
@@ -471,28 +569,11 @@
 			      (print "(mapper " (string-intersperse (list runkey runname area area-path reason contour mode-patt) ", ") ")")
 			      (mapper runkey runname area area-path reason contour mode-patt))
 			    (case callname
 			      ((auto) runname)
 			      (else   runtrans)))))
-	 (new-target (if area-xlatr 
-			 (let ((xlatr-key (string->symbol area-xlatr)))
-			   (if (hash-table-exists? *target-mappers* xlatr-key)
-			       (begin
-				 (print "Using target mapper: " area-xlatr)
-				 (handle-exceptions
-				     exn
-				     (begin
-				       (print "FAILED TO RUN TARGET MAPPER FOR " area ", called " area-xlatr)
-				       (print "   function is: " (hash-table-ref/default *target-mappers* xlatr-key #f ) )
-				       (print " message: " ((condition-property-accessor 'exn 'message) exn))
-				       runkey)
-				   ((hash-table-ref *target-mappers* xlatr-key)
-				    runkey new-runname area area-path reason contour mode-patt)))
-			       (begin
-				 (print "ERROR: Failed to find named target translator " xlatr-key ", using original target.")
-				 runkey)))
-			 runkey))
+	 (new-target     target) ;; I believe we will want target manipulation here .. (map-targets xlatr-key runkey area contour))
 	 (actual-action  (if action
 			     (if (equal? action "sync-prepend")
 				 "sync"
 				 action)
 			     "run"))) ;; this has gotten a bit ugly. Need a function to handle actions processing.
@@ -499,11 +580,11 @@
     ;; some hacks to remove switches not needed in certain cases
     (case (string->symbol (or action "run"))
       ((sync sync-prepend)
        (set! new-target #f)
        (set! runame     #f)))
-    (print "area-path: " area-path " area-xlatr: " area-xlatr " orig-target: " runkey " new-target: " new-target)
+    ;; (print "area-path: " area-path " orig-target: " runkey " new-target: " new-target)
     (let-values (((uuid pkt)
 		  (command-line->pkt
 		   actual-action
 		   (append 
 		    `(("-start-dir"  . ,area-path)
@@ -523,23 +604,50 @@
 			    (equal? action "run"))
 			`(("-preclean"  . " ")
 			  ("-rerun-all" . " "))      ;; if run we *always* want preclean set, use single space as placeholder
 			'())
 		    )
-		   sched)))
+		   sched
+                   extra-dat: `(a ,runkey)  ;; we need the run key for marking the run as launched
+                   )))
       (with-output-to-file
 	  (conc pktsdir "/" uuid ".pkt")
 	(lambda ()
 	  (print pkt))))))
+
+;; look for areas=a1,a2,a3 OR areafn=somefuncname
+;;
+(define (val-alist->areas val-alist)
+  (let ((areas-string   (alist-ref 'areas  val-alist))
+	(areas-procname (alist-ref 'areafn val-alist)))
+    (if areas-procname ;; areas-procname take precedence
+	areas-procname
+	(string-split (or areas-string "") ","))))
+
+;; area   - the current area under consideration
+;; areas  - the list of allowed areas from the contour spec -OR-
+;;          if it is a string then it is the function to use to
+;;          lookup in *area-checkers*
+;;
+(define (area-allowed? area areas runkey contour mode-patt)
+  (cond
+   ((not areas) #t) ;; no spec
+   ((string? areas) ;; 
+    (let ((check-fn (hash-table-ref/default *area-checkers* (string->symbol areas) #f)))
+      (if check-fn
+	  (check-fn area runkey contour mode-patt)
+	  #f)))
+   ((list? areas)(member area areas))
+   (else #f))) ;; shouldn't get here 
 
 ;; (use trace)(trace create-run-pkt)
 
 ;; collect all needed data and create run pkts for contours with changed inputs
 ;;
 (define (generate-run-pkts mtconf toppath)
   (let ((std-runname (conc "sched"  (time->string (seconds->local-time (current-seconds)) "%M%H%d"))))
-    (with-queue-db
+    (common:with-queue-db
      mtconf
      (lambda (pktsdirs pktsdir pdb)
        (let* ((rgconfdat (find-and-read-config (conc toppath "/runconfigs.config")))
 	      (rgconf    (car rgconfdat))
 	      (all-areas (map car (configf:get-section mtconf "areas")))
@@ -561,29 +669,38 @@
 			(len-key    (length keyparts))
 			(ruletype   (if (> len-key 1)(cadr keyparts) #f))
 			(action     (if (> len-key 2)(caddr keyparts) #f))
 			(optional   (if (> len-key 3)(cadddr keyparts) #f))
 			;; (val-list   (string-split-fields ";\\s*" val #:infix)) ;; (string-split val)) ;; runname-rule params
-			(val-alist  (val->alist val))
+			(val-alist  (common:val->alist val))
 			(runname    (make-runname "" ""))
 			(runtrans   (alist-ref 'runtrans val-alist))
+
+			;; these may or may not be defined and not all are used in each handler type in the case below
+			(run-name   (alist-ref 'run-name val-alist))
+			(target     (alist-ref 'target   val-alist))
+			(crontab    (alist-ref 'cron     val-alist))
+			(areas      (val-alist->areas    val-alist)) ;; areas can be a single string (a reference to call an areas function), or a list of area names.
+			(dbdest     (alist-ref 'dbdest   val-alist))
+			(appendconf (alist-ref 'appendconf val-alist))
+			(file-globs (alist-ref 'glob val-alist))
 			
 			(runstarts  (find-pkts pdb '(runstart) `((o . ,contour)
 								 (t . ,runkey))))
-			(rspkts     (get-pkt-alists runstarts))
+			(rspkts     (common:get-pkt-alists runstarts))
 			;; starttimes is for run start times and is used to know when the last run was launched
-			(starttimes (get-pkt-times rspkts)) ;; sort by age (youngest first) and delete duplicates by target
-			(last-run (if (null? starttimes) ;; if '() then it has never been run, else get the max
-				      0
-				      (apply max (map cdr starttimes))))
+			(starttimes (common:get-pkt-times rspkts)) ;; sort by age (youngest first) and delete duplicates by target
+			(last-run   (if (null? starttimes) ;; if '() then it has never been run, else get the max
+					0
+					(apply max (map cdr starttimes))))
 			;; synctimes is for figuring out the last time a sync was done
-			(syncstarts   (find-pkts pdb '(syncstart) '())) ;; no qualifiers, a sync does all tarets etc.
-			(sspkts       (get-pkt-alists syncstarts))
-			(synctimes    (get-pkt-times  sspkts))
-			(last-sync (if (null? synctimes) ;; if '() then it has never been run, else get the max
-				      0
-				      (apply max (map cdr synctimes))))
+			(syncstarts (find-pkts pdb '(syncstart) '())) ;; no qualifiers, a sync does all tarets etc.
+			(sspkts       (common:get-pkt-alists syncstarts))
+			(synctimes    (common:get-pkt-times  sspkts))
+			(last-sync  (if (null? synctimes) ;; if '() then it has never been run, else get the max
+					0
+					(apply max (map cdr synctimes))))
 			)
 
 		   (let ((delta (lambda (x)
 				  (round (/ (- (current-seconds) x) 60)))))
 		     (print "runkey: " runkey ", ruletype: " ruletype ", action: " action ", last-run: " last-run " time since; last-run: " (delta last-run) ", last-sync: " (delta last-sync)))
@@ -597,41 +714,53 @@
 		   
 		   (case (string->symbol (or ruletype "no-such-rule"))
 
 		     ((no-such-rule) (print "ERROR: no such rule for " sense))
 
+		     ;; Handle crontab like rules
+		     ;;
 		     ((scheduled)
 		      (if (not (alist-ref 'cron val-alist)) ;; gotta have cron spec
 			  (print "ERROR: bad sense spec \"" (string-intersperse sense " ") "\" params: " val-alist)
-			  (let* ((run-name (alist-ref 'run-name val-alist))
-				 (target   (alist-ref 'target   val-alist))
-				 (crontab  (alist-ref 'cron     val-alist))
+			  (let* (
 				 ;; (action   (alist-ref 'action   val-alist))
-				 (cron-safe-string (string-translate (string-intersperse (string-split (alist-ref 'cron val-alist)) "-") "*" "X"))
+				 (cron-safe-string (string-translate (string-intersperse (string-split crontab) "-") "*" "X"))
 				 (runname  std-runname)) ;; (conc "sched" (time->string (seconds->local-time (current-seconds)) "%M%H%d")))))
 			    ;; (print "last-run: " last-run " need-run: " need-run)
 			    ;; (if need-run
 			    (case (string->symbol action)
 			      ((sync sync-prepend)
 			       (if (common:extended-cron crontab #f last-sync)
 				   (push-run-spec torun contour runkey
 						  `((message . ,(conc ruletype ":sync-" cron-safe-string))
 						    (action  . ,action)
-						    (dbdest  . ,(alist-ref 'dbdest val-alist))
-						    (append  . ,(alist-ref 'appendconf val-alist))))))
+						    (dbdest  . ,dbdest)
+						    (append  . ,appendconf)
+						    (areas   . ,areas)))))
 			      ((run)
 			       (if (common:extended-cron crontab #f last-run)
 				   (push-run-spec torun contour runkey
-						  `((message . ,(conc ruletype ":" cron-safe-string))
-						    (runname . ,runname)
+						  `((message  . ,(conc ruletype ":" cron-safe-string))
+						    (runname  . ,runname)
+						    (runtrans . ,runtrans)
+						    (action   . ,action)
+						    (areas    . ,areas)
+						    (target   . ,target)))))
+                              ((remove)
+                               (push-run-spec torun contour runkey
+						  `((message  . ,(conc ruletype ":" cron-safe-string))
+						    (runname  . ,runname)
 						    (runtrans . ,runtrans)
-						    (action  . ,action)
-						    (target  . ,target)))))
+						    (action   . ,action)
+						    (areas    . ,areas)
+						    (target   . ,target))))
 			      (else
 			       (print "ERROR: action \"" action "\" has no scheduled handler")
 			       )))))
 
+		     ;; script based sensors
+		     ;;
 		     ((script)
 		      ;; syntax is a little different here. It is a list of commands to run, "scriptname = extra_parameters;scriptname = ..."
 		      ;; where scriptname may be repeated multiple times. The script must return unix-epoch of last change, new-target-name and new-run-name
 		      ;; the script is called like this:  scriptname contour runkey std-runname action extra_param1 extra_param2 ...
 		      (for-each
@@ -664,19 +793,23 @@
 				 (if need-run
 				     (let* ((key-msg    `((message  . ,(conc ruletype ":" message))
 							  (runname  . ,runname)
 							  (runtrans . ,runtrans)
 							  (action   . ,action)
-							  (target   . ,new-target))))
+							  (areas    . ,areas)
+							  (target   . ,new-target) ;; overriding with result from runing the script
+                                                          )))
 				       (print "key-msg: " key-msg)
 				       (push-run-spec torun contour
 						      (if optional  ;; we need to be able to differentiate same contour, different behavior. 
 							  (conc runkey ":" optional)  ;; NOTE: NOT COMPLETELY IMPLEMENTED. DO NOT USE
 							  runkey)
 						      key-msg)))))))
 		       val-alist)) ;; iterate over the param split by ;\s*
 
+		     ;; fossil scm based triggers
+		     ;;
 		     ((fossil)
 		      (for-each
 		       (lambda (fspec)
 			 (print "fspec: " fspec)
 			 (let* ((url         (symbol->string (car fspec))) ;; THIS COULD BE TROUBLE. Add option to reading line to return as string.
@@ -688,65 +821,78 @@
 			   (fossil:clone-or-sync url fname fdir) ;; )
 			   (let-values (((datetime node)
 					 (fossil:last-change-node-and-time fdir fname branch)))
 			     (if (null? starttimes)
 				 (push-run-spec torun contour runkey
-						`((message . ,(conc "fossil:" branch "-neverrun"))
-						  (runname . ,(conc runname "-" node))
+						`((message  . ,(conc "fossil:" branch "-neverrun"))
+						  (runname  . ,(conc runname "-" node))
 						  (runtrans . ,runtrans)
-						  (target  . ,runkey)))
+						  (areas    . ,areas)
+						  ;; (target   . ,runkey)
+						  (action   . ,action)
+                                                  ))
 				 (if (> datetime last-run) ;; change time is greater than last-run time
 				     (push-run-spec torun contour runkey
-						    `((message . ,(conc "fossil:" branch "-" node))
-						      (runname . ,(conc runname "-" node))
+						    `((message  . ,(conc "fossil:" branch "-" node))
+						      (runname  . ,(conc runname "-" node))
 						      (runtrans . ,runtrans)
-						      (target  . ,runkey)))))
+						      (areas    . ,areas)
+						      ;; (target   . ,runkey)
+						      (action   . ,action)
+						      (branch   . ,branch)
+						      (url      . ,url)
+						      (clone    . ,(conc fdir "/" fname))
+                                                      ))))
 			     (print "Got datetime=" datetime " node=" node))))
 		       val-alist))
-		     
+
+		     ;; sensor looking for one or more files newer than reference
+		     ;;
 		     ((file file-or) ;; one or more files must be newer than the reference
-		      (let* ((file-globs  (alist-ref 'glob val-alist))
-			     (youngestdat (common:get-youngest (common:bash-glob file-globs)))
+		      (let* ((youngestdat (common:get-youngest (common:bash-glob file-globs)))
 			     (youngestmod (car youngestdat)))
 			;; (print "youngestmod: " youngestmod " starttimes: " starttimes)
 			(if (null? starttimes) ;; this target has never been run
 			    (push-run-spec torun contour runkey
-					   `((message . "file:neverrun")
-					     (action  . ,action)
+					   `((message  . "file:neverrun")
+					     (action   . ,action)
 					     (runtrans . ,runtrans)
-					     (target  . ,runkey)
-					     (runname . ,runname)))
+					     ;; (target   . ,runkey)
+					     (areas    . ,areas)
+					     (runname  . ,runname)))
 			;; (for-each
 			;;  (lambda (starttime) ;; look at the time the last run was kicked off for this contour
 			;;    (if (> youngestmod (cdr starttime))
 			;; 	   (begin
 			;; 	     (print "starttime younger than youngestmod: " starttime " Youngestmod: " youngestmod)
 			    (if (> youngestmod last-run)
 				(push-run-spec torun contour runkey
-					       `((message . ,(conc ruletype ":" (cadr youngestdat)))
-						 (action  . ,action)
-						 (target  . ,runkey)
+					       `((message  . ,(conc ruletype ":" (cadr youngestdat)))
+						 (action   . ,action)
+						 ;; (target   . ,runkey)
 						 (runtrans . ,runtrans)
-						 (runname . ,runname)
+						 (areas    . ,areas)
+						 (runname  . ,runname)
 						 ))))))
-		      ;; starttimes))
 
+		     ;; all globbed files must be newer than the reference
+		     ;;
 		     ((file-and) ;; all files must be newer than the reference
-		      (let* ((file-globs  (alist-ref 'glob val-alist))
-			     (youngestdat (common:get-youngest file-globs))
+		      (let* ((youngestdat (common:get-youngest file-globs))
 			     (youngestmod (car youngestdat))
 			     (success     #t)) ;; any cases of not true, set flag to #f for AND
 			;; (print "youngestmod: " youngestmod " starttimes: " starttimes)
 			(if (null? starttimes) ;; this target has never been run
 			    (push-run-spec torun contour runkey
-					   `((message . "file:neverrun")
-					     (runname . ,runname)
+					   `((message  . "file:neverrun")
+					     (runname  . ,runname)
 					     (runtrans . ,runtrans)
-					     (target  . ,runkey)
-					     (action  . ,action)))
+					     (areas    . ,areas)
+					     ;; (target   . ,runkey)
+					     (action   . ,action)))
 			    ;; NB// I think this is wrong. It should be looking at last-run only.
-			    (if (> youngestmod last-run)
+			    (if (> youngestmod last-run) ;; WAIT!! Shouldn't file-and be looking at the *oldest* file (thus all are younger than ...)
 				
 				;; 			    (for-each
 				;; 			     (lambda (starttime) ;; look at the time the last run was kicked off for this contour
 				;; 			       (if (< youngestmod (cdr starttime))
 				;; 				   (set! success #f)))
@@ -753,82 +899,99 @@
 				;; 			     starttimes))
 				;; 			(if success
 				;; 			    (begin
 				;; 			      (print "starttime younger than youngestmod: " starttime " Youngestmod: " youngestmod)
 				(push-run-spec torun contour runkey
-					       `((message . ,(conc ruletype ":" (cadr youngestdat)))
-						 (runname . ,runname)
+					       `((message  . ,(conc ruletype ":" (cadr youngestdat)))
+						 (runname  . ,runname)
 						 (runtrans . ,runtrans)
-						 (target  . ,runkey)
-						 (action  . ,action)
+						 ;; (target   . ,runkey)
+						 (areas    . ,areas)
+						 (action   . ,action)
 						 ))))))
 		     (else (print "ERROR: unrecognised rule \"" ruletype)))))
 	       keydats))) ;; sense rules
 	  (hash-table-keys rgconf))
 	 
 	 ;; now have to run populated
 	 (for-each
 	  (lambda (contour)
-	    (print "contour: " contour)
-	    (let* ((val       (or (configf:lookup mtconf "contours" contour) ""))
-		   (val-alist (val->alist val))
-		   (areas     (string-split (or (alist-ref 'areas val-alist) "") ","))
-		   (selector  (alist-ref 'selector val-alist))
-		   (mode-tag  (and selector (string-split-fields "/" selector #:infix)))
-		   (mode-patt (and mode-tag (if (eq? (length mode-tag) 2)(cadr mode-tag) #f)))
-		   (tag-expr  (and mode-tag (if (null? mode-tag) #f (car mode-tag)))))
+	    (let* ((cval       (or (configf:lookup mtconf "contours" contour) ""))
+		   (cval-alist (common:val->alist cval))                     ;; BEWARE ... NOT the same val-alist as above!
+		   (areas      (val-alist->areas cval-alist))
+		   (selector   (alist-ref 'selector cval-alist))
+		   (mode-tag   (and selector (string-split-fields "/" selector #:infix)))
+		   (mode-patt  (and mode-tag (if (eq? (length mode-tag) 2)(cadr mode-tag) #f)))
+		   (tag-expr   (and mode-tag (if (null? mode-tag) #f (car mode-tag)))))
+	      (print "contour: " contour " areas=" areas " cval=" cval)
 	      (for-each
-	       (lambda (runkeydatset)
+	       (lambda (runkeydatset) 
 		 ;; (print "runkeydatset: ")(pp runkeydatset)
 		 (let ((runkey     (car runkeydatset))
 		       (runkeydats (cadr runkeydatset)))
 		   (for-each
 		    (lambda (runkeydat)
 		      (for-each
 		       (lambda (area)
-			 (let ((runname (alist-ref 'runname runkeydat))
-			       (runtrans (alist-ref 'runtrans runkeydat))
-			       (reason  (alist-ref 'message runkeydat))
-			       (sched   (alist-ref 'sched   runkeydat))
-			       (action  (alist-ref 'action  runkeydat))
-			       (dbdest  (alist-ref 'dbdest  runkeydat))
-			       (append  (alist-ref 'append  runkeydat))
-			       (target  (or (alist-ref 'target  runkeydat) runkey))) ;; override with target if forced
-			   (print "Have: runkey=" runkey " contour=" contour " area=" area " action=" action " tag-expr=" tag-expr " mode-patt=" mode-patt " target=" target)
-			   (if (case (or (and action (string->symbol action)) 'noaction)  ;; ensure we have the needed data to run this action
-				 ((noaction) #f)
-				 ((run)      (and runname reason))
-				 ((sync sync-prepend)     (and reason dbdest))
-				 (else       #f))
-			       ;; instead of unwrapping the runkeydat alist, pass it directly to create-run-pkt
-			       (create-run-pkt mtconf action area runkey runname mode-patt tag-expr pktsdir reason contour sched dbdest append runtrans) 
-			       (print "ERROR: Missing info to make a " action " call: runkey=" runkey " contour=" contour " area=" area  " tag-expr=" tag-expr " mode-patt=" mode-patt " dbdest=" dbdest)
-			       )))
-		       all-areas))
+			 (if (area-allowed? area areas runkey contour mode-patt) ;; is this area to be handled (from areas=a,b,c OR using areafn=abcfn and *area-checks* ...)
+                             (let* ((aval       (or (configf:lookup mtconf "areas" area) ""))
+                                    (aval-alist (common:val->alist aval))
+                                    (runname    (alist-ref 'runname runkeydat))
+                                    (runtrans   (alist-ref 'runtrans runkeydat))
+                                    
+                                    (reason     (alist-ref 'message runkeydat))
+                                    (sched      (alist-ref 'sched   runkeydat))
+                                    (action     (alist-ref 'action  runkeydat))
+                                    (dbdest     (alist-ref 'dbdest  runkeydat))
+                                    (append     (alist-ref 'append  runkeydat))
+                                    (targets    (or (alist-ref 'target  runkeydat)
+                                                    (map-targets mtconf aval-alist runkey area contour)))) ;; override with target if forced
+                               ;; NEED TO EXPAND RUNKEY => ALL TARGETS MAPPED AND THEN FOREACH .... 
+                               (for-each
+                                (lambda (target)
+                                  (print "Creating pkt for runkey=" runkey " target=" target " contour=" contour " area=" area " action=" action " tag-expr=" tag-expr " mode-patt=" mode-patt)
+                                  (if (case (or (and action (string->symbol action)) 'noaction)  ;; ensure we have the needed data to run this action
+                                        ((noaction)           #f)
+                                        ((run)                (and runname reason))
+                                        ((sync sync-prepend)  (and reason dbdest))
+                                        (else                 #f))
+                                      ;; instead of unwrapping the runkeydat alist, pass it directly to create-run-pkt
+                                      (create-run-pkt mtconf action area runkey target runname mode-patt
+                                                      tag-expr pktsdir reason contour sched dbdest append 
+                                                      runtrans) 
+                                      (print "ERROR: Missing info to make a " action " call: runkey=" runkey " contour=" contour " area=" area  " tag-expr=" tag-expr " mode-patt=" mode-patt " dbdest=" dbdest)
+                                      ))
+                                targets))
+                             (print "NOTE: skipping " runkeydat " for area \"" area "\", not in " areas)))
+                       all-areas))
 		    runkeydats)))
 	       (let ((res (configf:get-section torun contour))) ;; each contour / target
 		 ;; (print "res=" res)
 		 res))))
 	  (hash-table-keys torun)))))))
 
 (define (pkt->cmdline pkta)
-  (let ((action (or (lookup-action-by-key (alist-ref 'a pkta)) "noaction")))
+  (let* ((param-mapping-alist (common:get-param-mapping flavor: 'switch-symbol))
+         (action        (or (lookup-action-by-key (alist-ref 'A pkta)) "noaction"))
+	 (action-param  (case (string->symbol action)
+                          ((-set-state-status) (conc (alist-ref 'l pkta) " "))
+                          (else ""))))
     (fold (lambda (a res)
 	    (let* ((key (car a)) ;; get the key name
 		   (val (cdr a))
 		   (par (or (lookup-param-by-key key)  ;; need to check also if it is a switch
 			    (lookup-param-by-key key inlst: *switch-keys*))))
 	      ;; (print "key: " key " val: " val " par: " par)
 	      (if par
-		  (conc res " " (param-translate par) " " val)
-		  (if (member key '(a Z U D T)) ;; a is the action
+		  (conc res " " (alist-ref (string->symbol par) param-mapping-alist eq? par) " " val)
+		  (if (alist-ref key *additional-cards*) ;; these cards do not translate to parameters or switches
 		      res
 		      (begin
 			(print "ERROR: Unknown key in packet \"" key "\" with value \"" val "\"")
 			res)))))
 	  (conc "megatest " (if (not (member action '("sync")))
-				(conc action " ")
+				(conc action " " action-param)
 				""))
 	  pkta)))
 
 ;; (use trace)(trace pkt->cmdline)
 
@@ -851,12 +1014,16 @@
 		     #f
 		   (create-directory "logs")
 		   #t)
 		 #t)
 	     "logs"
-	     "/tmp")))
-    (with-queue-db
+	     "/tmp"))
+	(cpuload (alist-ref 'adj-proc-load (common:get-normalized-cpu-load #f)))
+	(maxload (string->number (or (configf:lookup mtconf "setup" "maxload")
+				     (configf:lookup mtconf "jobtools" "maxload") ;; respect value used by Megatest calls
+				     "1.1"))))
+    (common:with-queue-db
      mtconf
      (lambda (pktsdirs pktsdir pdb)
        (let* ((rgconfdat (find-and-read-config (conc toppath "/runconfigs.config")))
 	      (rgconf    (car rgconfdat))
 	      (areas     (configf:get-section mtconf "areas"))
@@ -865,85 +1032,222 @@
 	      (torun     (make-hash-table)) ;; target => ( ... info ... )
 	      (rgentargs (hash-table-keys rgconf))) ;; these are the targets registered for automatically triggering
 	 (for-each
 	  (lambda (pktdat)
 	    (let* ((pkta    (alist-ref 'apkt pktdat))
-		   (action  (alist-ref 'a pkta))
+		   (action  (alist-ref 'A pkta))
 		   (cmdline (pkt->cmdline pkta))
 		   (uuid    (alist-ref 'Z pkta))
+		   (user    (alist-ref 'U pkta))
+		   (area    (alist-ref 'G pkta))
 		   (logf    (conc logdir "/" uuid "-run.log"))
 		   (fullcmd (conc "NBFAKE_LOG=" logf " nbfake " cmdline)))
-	      (print "RUNNING: " fullcmd)
-	      (system fullcmd)
-	      (mark-processed pdb (list (alist-ref 'id pktdat)))
-	      (let-values (((ack-uuid ack-pkt)
-			    (add-z-card
-			     (construct-sdat 'P uuid
-					     'T (case (string->symbol action)
-						  ((run) "runstart")
-						  ((sync) "syncstart")    ;; example of translating run -> runstart
-						  (else   action))
-					     'c (alist-ref 'o pkta) ;; THIS IS WRONG! SHOULD BE 'c
-					     't (alist-ref 't pkta)))))
-		(write-pkt pktsdir ack-uuid ack-pkt))))
+	      (if (check-access user mtconf action area)
+		  (if (and (> cpuload maxload)
+			   (member action '("run" "archive"))) ;; do not run archive or run if load is over the specified limit
+		      (print "WARNING: cpuload too high, skipping processing of " uuid)
+		      (begin
+			(print "RUNNING: " fullcmd)
+			(system fullcmd) ;; replace with process ...
+			(mark-processed pdb (list (alist-ref 'id pktdat)))
+			(let-values (((ack-uuid ack-pkt)
+				      (add-z-card
+				       (construct-sdat 'P uuid
+						       'T (case (string->symbol action)
+							    ((run) "runstart")
+							    ((sync) "syncstart")    ;; example of translating run -> runstart
+							    (else   action))
+						       'c (alist-ref 'o pkta) ;; THIS IS WRONG! SHOULD BE 'c
+						       't (alist-ref 't pkta)))))
+			  (write-pkt pktsdir ack-uuid ack-pkt))))
+		  (begin ;; access denied! Mark as such
+		    (mark-processed pdb (list (alist-ref 'id pktdat)))
+		    (let-values (((ack-uuid ack-pkt)
+				  (add-z-card
+				   (construct-sdat 'P uuid
+						   'T "access-denied"
+						   'c (alist-ref 'o pkta) ;; THIS IS WRONG! SHOULD BE 'c
+						   't (alist-ref 't pkta)))))
+		      (write-pkt pktsdir ack-uuid ack-pkt))))))
 	  pkts))))))
-  
+
+(define (check-access user mtconf action area)
+  ;; NOTE: Need control over defaults. E.g. default might be no access
+  (let* ((access-ctrl (hash-table-exists? mtconf "access"))  ;; if there is an access section the default is to REQUIRE enablement/access
+	 (access-list (map (lambda (x)
+			     (string-split x ":"))
+			   (string-split (or (configf:lookup mtconf "access" area) ;; userid:rightstype userid2:rightstype2 ...
+					     (if access-ctrl
+						 "*:none"  ;; nobody has access by default
+						 "*:all")))))
+	 (access-types-dat (configf:get-section mtconf "accesstypes")))
+    (debug:print 0 *default-log-port* "Checking access in " access-list " with access-ctrl " access-ctrl " for area " area)
+    (if access-ctrl
+	(let* ((user-access     (or (assoc user access-list)
+				    (assoc "*"  access-list)))
+	       (access-type     (cadr user-access))
+	       (access-types    (let ((res (alist-ref access-type access-types-dat equal?)))
+				  (if res (car res) res)))
+	       (allowed-actions (string-split (or access-types ""))))
+	  (print "Got " allowed-actions " for user " user " where access-types=" access-types " access-type=" access-type)
+	  (cond
+	   ((and access-types (member action allowed-actions))
+	    ;; (print "Access granted for " user " for " action)
+	    #t)
+	   (else
+	    ;; (print "Access denied for " user " for " action)
+	    #f))))))
+
 (define (get-pkts-dir mtconf)
   (let ((pktsdirs  (configf:lookup mtconf "setup" "pktsdirs"))
 	(pktsdir   (if pktsdirs (car (string-split pktsdirs " ")) #f)))
     pktsdir))
 
 (let ((debugcontrolf (conc (get-environment-variable "HOME") "/.mtutilrc")))
-  (if (file-exists? debugcontrolf)
+  (if (common:file-exists? debugcontrolf)
       (load debugcontrolf)))
 
 (if *action*
     (case (string->symbol *action*)
-      ((run remove rerun set-ss archive kill)
+      ((run remove rerun set-ss archive kill list)
        (let* ((mtconfdat (simple-setup (args:get-arg "-start-dir")))
 	      (mtconf    (car mtconfdat))
+	      (area      (args:get-arg "-area")) ;; look up the area to dispatch to from [areas] section
+	      (areasec   (if area (configf:lookup mtconf "areas" area) #f))
+	      (areadat   (if areasec (common:val->alist areasec) #f))
+	      (area-path (if areadat (alist-ref 'path areadat) #f))
 	      (pktsdirs  (configf:lookup mtconf "setup" "pktsdirs"))
 	      (pktsdir   (if pktsdirs (car (string-split pktsdirs " ")) #f))
-	      (adjargs   (hash-table-copy args:arg-hash)))
+	      (adjargs   (hash-table-copy args:arg-hash))
+	      (new-ss    (args:get-arg "-new")))
+	 ;; check a few things
+	 (cond
+	  ((and area (not area-path))
+	   (print "ERROR: the specified area was not found in the [areas] table. Area name=" area)
+	   (exit 1))
+	  ((not area)
+	   (print "ERROR: no area specified. Use -area ")
+	   (exit 1))
+	  (else
+	   (let ((user (current-user-name)))
+	     (if (check-access user mtconf *action* area);; check rights
+		 (print "Access granted for " *action* " action by " user)
+		 (begin
+		   (print "Access denied for " *action* " action by " user)
+		   (exit 1))))))
+	 
 	 ;; (for-each
 	 ;;  (lambda (key)
 	 ;;    (if (not (member key *legal-params*))
 	 ;; 	(hash-table-delete! adjargs key))) ;; we need to delete any params intended for mtutil
 	 ;;  (hash-table-keys adjargs))
 	 (let-values (((uuid pkt)
-		       (command-line->pkt *action* adjargs #f)))
+		       (command-line->pkt *action* adjargs #f area-path: area-path new-ss: new-ss)))
 	   (write-pkt pktsdir uuid pkt))))
       ((dispatch import rungen process)
        (let* ((mtconfdat (simple-setup (args:get-arg "-start-dir")))
 	      (mtconf    (car mtconfdat))
-	      (toppath   (configf:lookup mtconf "dyndat" "toppath")))
+	      (toppath   (configf:lookup mtconf "scratchdat" "toppath")))
 	 (case (string->symbol *action*)
 	   ((process)  (begin
-			 (load-pkts-to-db mtconf)
+			 (common:load-pkts-to-db mtconf)
 			 (generate-run-pkts mtconf toppath)
-			 (load-pkts-to-db mtconf)
+			 (common:load-pkts-to-db mtconf)
 			 (dispatch-commands mtconf toppath)))
-	   ((import)   (load-pkts-to-db mtconf)) ;; import pkts
+	   ((import)   (common:load-pkts-to-db mtconf)) ;; import pkts
 	   ((rungen)   (generate-run-pkts mtconf toppath))
 	   ((dispatch) (dispatch-commands mtconf toppath)))))
+      ;; misc
+      ((show)
+       (if (> (length remargs) 0)
+	   (let* ((mtconfdat (simple-setup (args:get-arg "-start-dir")))
+		  (mtconf    (car mtconfdat))
+		  (sect-dat (configf:get-section mtconf (car remargs))))
+	     (if sect-dat
+		 (for-each
+		  (lambda (entry)
+		    (if (> (length entry) 1)
+			(print (car entry) "   " (cadr entry))
+			(print (car entry))))
+		  sect-dat)
+		 (print "No section \"" (car remargs) "\" found")))
+	   (print "ERROR: list requires section parameter; areas, setup or contours")))
+      ((gendot)
+       (let* ((mtconfdat (simple-setup (args:get-arg "-start-dir")))
+	      (mtconf    (car mtconfdat)))
+	 (common:load-pkts-to-db mtconf use-lt: #t) ;; need to NOT do this by default ...
+	 (common:with-queue-db
+	  mtconf
+	  (lambda (pktsdirs pktsdir conn)
+	    ;;                       pktspec display-fields 
+	    (make-report "out.dot" conn
+			 '((cmd      . ((parent . P)
+					(user   . M)
+					(target . t)))
+			   (runstart . ((parent . P)
+					(target . t)))
+			   (runtype . ((parent . P)))) ;; pktspec
+			 '(P U t)                                                     ;; 
+			 )))))  ;; no ptypes listed (ptypes are strings of pkt types to read from db
       ((db)
        (if (null? remargs)
 	   (print "ERROR: missing sub command for db command")
 	   (let ((subcmd (car remargs)))
 	     (case (string->symbol subcmd)
 	       ((pgschema)
 		(let* ((install-home (common:get-install-area))
 		       (schema-file  (conc install-home "/share/db/mt-pg.sql")))
-		  (if (file-exists? schema-file)
+		  (if (common:file-exists? schema-file)
 		      (system (conc "/bin/cat " schema-file)))))
 	       ((sqlite3schema)
 		(let* ((install-home (common:get-install-area))
 		       (schema-file  (conc install-home "/share/db/mt-sqlite3.sql")))
-		  (if (file-exists? schema-file)
+		  (if (common:file-exists? schema-file)
 		      (system (conc "/bin/cat " schema-file)))))
 	       ((junk)
-		(rmt:get-keys))))))))
+		(rmt:get-keys))))))
+      ((tsend)
+       (if (null? remargs)
+	   (print "ERROR: missing data to send to trigger listeners")
+	   (let* ((msg       (car remargs))
+                  (mtconfdat (simple-setup (args:get-arg "-start-dir")))
+                  (mtconf    (car mtconfdat))
+                  (listeners (configf:get-section mtconf "listeners"))
+                  (prev-seen (make-hash-table))) ;; catch duplicates
+             (for-each
+              (lambda (listener)
+                (let ((host-port (car listener))
+                      (remdat    (cdr listener)))
+                  (print "sending " msg " to " host-port)
+                  (open-send-close-nn host-port msg timeout: 2)))
+              listeners))))
+      ((tlisten)
+       (if (null? remargs)
+           (print "ERROR: useage for tlisten is \"mtutil tlisten portnum\"")
+           (let ((portnum (string->number (car remargs))))
+              
+             (if (not portnum)
+                 (print "ERROR: the portnumber parameter must be a number, you gave: " (car remargs))
+                 (begin
+                   (if (not (is-port-in-use portnum))  
+                       (let* ((rep       (start-nn-server portnum))
+                           (mtconfdat (simple-setup (args:get-arg "-start-dir")))
+                           (mtconf    (car mtconfdat))
+                           (script    (configf:lookup mtconf "listener" "script")))
+                           (print "Listening on port " portnum " for messages")
+														(set-signal-handler! signal/int  special-signal-handler)
+														(set-signal-handler! signal/term special-signal-handler)
+
+                            (let loop ((instr (nn-recv rep)))
+                               (print "received " instr ", running \"" script " " instr "\"")
+                               (system (conc script " '" instr "'"))
+                               (nn-send rep "ok")
+                               (loop (nn-recv rep))))
+                     (print "ERROR: Port " portnum " already in use. Try another port")))))))
+      
+      )) ;; the end
+             
 
 ;; If HTTP_HOST is defined then we must be in the cgi environment
 ;; so run stml and exit
 ;;
 (if (get-environment-variable "HTTP_HOST")
@@ -963,5 +1267,11 @@
       (install-history-file (get-environment-variable "HOME") ".mtutil_history") ;;  [homedir] [filename] [nlines])
       (current-input-port (make-readline-port "mtutil> "))
       (if (args:get-arg "-repl")
 	  (repl)
 	  (load (args:get-arg "-load")))))
+
+#|
+(define mtconf (car (simple-setup #f)))
+(define dat (common:with-queue-db mtconf (lambda (conn)(get-pkts conn '()))))
+(pp (pkts#flatten-all dat '((cmd . ((parent . P)(url . M)))(runtype . ((parent . P)))) 'id 'group-id 'uuid 'parent 'pkt-type 'pkt 'processed))
+|#

Index: newdashboard.scm
==================================================================
--- newdashboard.scm
+++ newdashboard.scm
@@ -84,11 +84,11 @@
       (print help)
       (exit)))
 
 ;; ease debugging by loading ~/.dashboardrc
 (let ((debugcontrolf (conc (get-environment-variable "HOME") "/.dashboardrc")))
-  (if (file-exists? debugcontrolf)
+  (if (common:file-exists? debugcontrolf)
       (load debugcontrolf)))
 
 (debug:setup)
 
 (define *tim* (iup:timer))
@@ -375,11 +375,11 @@
       #f))
 
 (define (test-panel window-id)
   (let* ((curr-row-num 0)
 	 (viewlog    (lambda (x)
-		       (if (file-exists? logfile)
+		       (if (common:file-exists? logfile)
 					;(system (conc "firefox " logfile "&"))
 			   (iup:send-url logfile)
 			   (message-window (conc "File " logfile " not found")))))
 	 (xterm      (lambda (x)
 		       (if (directory-exists? rundir)
@@ -730,14 +730,15 @@
 		       (lambda (x)
 			 ;; Want to dedicate no more than 50% of the time to this so skip if
 			 ;; 2x delta time has not passed since last query
 			 (if (< nextmintime (current-milliseconds))
 			     (let* ((starttime (current-milliseconds))
-				    (changes   (dcommon:run-update keys data runname keypatts testpatt states statuses 'full my-window-id))
+				    ;; (changes   (dcommon:run-update keys data runname keypatts testpatt states statuses 'full my-window-id))
 				    (endtime   (current-milliseconds)))
 			       (set! nextmintime (+ endtime (* 2 (- endtime starttime))))
-			       (debug:print 11 *default-log-port* "CHANGE(S): " (car changes) "..."))
+			       ;; (debug:print 11 *default-log-port* "CHANGE(S): " (car changes) "..."))
+                               )
 			     (debug:print-info 11 *default-log-port* "Server overloaded"))))))
 
 ;; (dboard:data-updaters-set! *data* (make-hash-table))
 (newdashboard #f) ;; *dbstruct-local*)    
 (iup:main-loop)

ADDED   nexttag.rb
Index: nexttag.rb
==================================================================
--- /dev/null
+++ nexttag.rb
@@ -0,0 +1,46 @@
+#!/usr/bin/env ruby
+
+
+def get_next_tag(branch)
+
+
+
+  abort "Not on a version branch like v1.64 (got: >#{branch}<)" unless branch.match(/^v\d\.\d\d$/)
+  
+  #puts "this branch: #{branch}"
+
+  tag_pat = /#{branch}(\d\d)/
+  remote=`fsl remote`.chomp.sub(/^file:\/\//,'') # get tagset from origin
+  cmd="fossil tag -R '#{remote}' list"
+  tags = `#{cmd}`.split /\n/
+  abort "fossil command failed [#{cmd}]" if $? != 0
+  branch_tags = tags.find_all{|x| x.match(tag_pat) }.sort
+  if branch_tags.length == 0
+    return branch + "01"
+  else
+    latest_tag = branch_tags.last
+    m1 = latest_tag.match(tag_pat)
+    minor_digits = m1[1].to_i + 1
+    if (minor_digits % 10) == 0
+      minor_digits += 1
+    end
+    new_tag=sprintf("%s%02d", branch, minor_digits)
+    return new_tag
+  end
+end
+
+branch = `fossil branch`.sub(/\A.*\* /m,'').sub(/\n.*\z/m,'')
+tag= get_next_tag(branch)
+
+puts "TODO: Write to megatest-version.scm:"
+puts ";; Always use two or four digit decimal
+;; 1.01, 1.02...1.10,1.11,1.1101 ... 1.99,2.00..
+
+(declare (unit megatest-version))
+
+(define megatest-version #{tag.sub(/^v/,'')})
+
+"
+
+puts "TODO: fossil tag add #{tag} #{branch}"
+puts ""

Index: ods.scm
==================================================================
--- ods.scm
+++ ods.scm
@@ -1,13 +1,22 @@
 ;; Copyright 2011, Matthew Welland.
 ;; 
-;;  This program is made available under the GNU GPL version 2.0 or
-;;  greater. See the accompanying file COPYING for details.
+;; This 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 csv-xml regex)
 (declare (unit ods))
 (declare (uses common))
 
@@ -197,11 +206,11 @@
 ;;   '( (sheet1 (r1c1 r1c2 r1c3 ...)
 ;;              (r2c1 r2c3 r2c3 ...) )
 ;;      (sheet2 ( ... )
 ;;              ( ... ) ) )
 (define (ods:list->ods path fname data)
-  (if (not (file-exists? path))
+  (if (not (common:file-exists? path))
       (print "ERROR: path to create ods data must pre-exist")
       (begin
 	(with-output-to-file (conc path "/content.xml")
 	  (lambda ()
 	    (ods:construct-dir path)

Index: oldsrc/fs-transport.scm
==================================================================
--- oldsrc/fs-transport.scm
+++ oldsrc/fs-transport.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 .
+;;
 
 (require-extension (srfi 18) extras tcp s11n)
 
 (use sqlite3 srfi-1 posix regex regex-case srfi-69 hostinfo md5 message-digest)
 (import (prefix sqlite3 sqlite3:))

ADDED   oldsrc/multi-dboard.scm
Index: oldsrc/multi-dboard.scm
==================================================================
--- /dev/null
+++ oldsrc/multi-dboard.scm
@@ -0,0 +1,801 @@
+;;======================================================================
+;; 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.
+;;======================================================================
+
+(use format numbers sql-de-lite srfi-1 posix regex regex-case srfi-69 srfi-18 call-with-environment-variables)
+(require-library iup)
+(import (prefix iup iup:))
+(use canvas-draw)
+
+(declare (uses margs))
+(declare (uses megatest-version))
+(declare (uses gutils))
+(declare (uses tree))
+(declare (uses configf))
+(declare (uses portlogger))
+(declare (uses keys))
+(declare (uses common))
+
+(include "common_records.scm")
+;; (include "db_records.scm")
+;; (include "key_records.scm")
+
+(define help (conc 
+	      "Megatest Dashboard, documentation at http://www.kiatoa.com/fossils/megatest
+  version " megatest-version "
+  license GPL, Copyright (C) Matt Welland 2011
+
+Usage: dashboard [options]
+  -h                : this help
+  -group groupname  : display this group of areas
+  -test testid      : control test identified by testid
+  -guimonitor       : control panel for runs
+
+Misc
+  -rows N         : set number of rows
+"))
+
+;; process args
+(define remargs (args:get-args 
+		 (argv)
+		 (list  "-group" ;; display this group of areas
+			"-debug"
+			) 
+		 (list  "-h"
+			"-v"
+			"-q"
+			)
+		 args:arg-hash
+		 0))
+
+(if (args:get-arg "-h")
+    (begin
+      (print help)
+      (exit)))
+
+;; (if (args:get-arg "-host")
+;;     (begin
+;;       (set! (common:get-remote remote) (string-split (args:get-arg "-host" ":")))
+;;       (client:launch))
+;;     (client:launch))
+
+(define *runremote* #f)
+(define *windows* (make-hash-table))
+(define *changed-main* (make-hash-table)) ;; set path/... => #t
+(define *changed-mutex* (make-mutex))     ;; use for all incoming change requests
+(define *searchpatts*   (make-hash-table))
+
+(debug:setup)
+
+(define *tim* (iup:timer))
+(define *ord* #f)
+
+(iup:attribute-set! *tim* "TIME" 300)
+(iup:attribute-set! *tim* "RUN" "YES")
+
+(define (message-window msg)
+  (iup:show
+   (iup:dialog
+    (iup:vbox 
+     (iup:label msg #:margin "40x40")))))
+
+(define (iuplistbox-fill-list lb items . default)
+  (let ((i 1)
+	(selected-item (if (null? default) #f (car default))))
+    (iup:attribute-set! lb "VALUE" (if selected-item selected-item ""))
+    (for-each (lambda (item)
+		(iup:attribute-set! lb (number->string i) item)
+		(if selected-item
+		    (if (equal? selected-item item)
+			(iup:attribute-set! lb "VALUE" item))) ;; (number->string i))))
+		(set! i (+ i 1)))
+	      items)
+    i))
+
+(define (pad-list l n)(append l (make-list (- n (length l)))))
+
+
+(define (mkstr . x)
+  (string-intersperse (map conc x) ","))
+
+(define (update-search x val)
+  (hash-table-set! *searchpatts* x val))
+
+
+;;======================================================================
+;; R E C O R D S
+;;======================================================================
+
+;; NOTE: Consider switching to defstruct.
+
+;; data for an area (regression or testsuite)
+;;
+(define-record areadat
+  name               ;; area name
+  path               ;; mt run area home
+  configdat          ;; megatest config
+  denoise            ;; focal point for not putting out same messages over and over
+  client-signature   ;; key for client-server conversation
+  remote             ;; hash of all the client side connnections
+  run-keys           ;; target keys for this area
+  runs               ;; used in dashboard, hash of run-ids -> rundat
+  read-only          ;; can I write to this area?
+  monitordb          ;; db handle for monitor.db
+  maindb             ;; db handle for main.db
+  )
+
+;; rundat, basic run data
+;;
+(define-record rundat
+  id                 ;; the run-id
+  target             ;; val1/val2 ... corrosponding to run-keys in areadat
+  runname
+  state              ;; state of the run, symbol 
+  status             ;; status of the run, symbol
+  event-time         ;; when the run was initiated
+  tests              ;; hash of test-id -> testdat, QUESTION: separate by run-id?
+  db                 ;; db handle
+  )
+
+;; testdat, basic test data
+(define-record testdat
+  run-id             ;; what run is this from
+  id                 ;; test id
+  testname           ;; test name
+  itempath           ;; item path
+  state              ;; test state, symbol
+  status             ;; test status, symbol
+  event-time         ;; when the test started
+  duration           ;; how long the test took
+  )
+
+;; general data for the dboard application
+;;
+(define-record data
+  cfgdat             ;; data from ~/.megatest/.dat
+  areas              ;; hash of areaname -> area-rec
+  current-window-id  ;; 
+  current-tab-id     ;; 
+  update-needed      ;; flag to indicate that the tab pointed to by current tab id needs refreshing immediately
+  tabs               ;; hash of tab-id -> areaname (??) should be of type "tab"
+  )
+
+;; all the components of an area display, all fits into a tab but
+;; parts may be swapped in/out as needed
+;;
+(define-record tab
+  tree
+  matrix    ;; the spreadsheet 
+  areadat   ;; the one-structure (one day dbstruct will be put in here)
+  view-path ;; //...
+  view-type ;; standard, etc.
+  controls  ;; the controls
+  data      ;; all the data kept in sync with db
+  filters   ;; user filters, alist name -> filter record, eventually store these in ~/.megatest/.dat?
+  run-id    ;; the current run-id
+  test-ids  ;; the current test id hash, run-id => test-id
+  command   ;; the command from the entry field
+  headers   ;; hash of header  -> colnum
+  rows      ;; hash of rowname -> rownum
+  )
+
+(define-record filter
+  target    ;; hash of widgets for the target
+  runname   ;; the runname widget
+  testpatt  ;; the testpatt widget
+  )
+
+;;======================================================================
+;; D B
+;;======================================================================
+
+;; These are all using sql-de-lite and independent of area so cannot use stuff 
+;; from db.scm
+
+;; NB// run-id=#f => return dbdir only
+;;
+(define (areadb:dbfile-path areadat run-id)
+  (let* ((cfgdat  (areadat-configdat areadat))
+	 (dbdir   (or (configf:lookup cfgdat "setup" "dbdir")
+		      (conc (configf:lookup cfgdat "setup" "linktree") "/.db")))
+	 (fname   (if run-id
+		      (case run-id
+			((-1) "monitor.db")
+			((0) "main.db")
+			(else (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)))
+
+;; -1 => monitor.db
+;;  0 => main.db
+;; >1 => .db
+;;
+(define (areadb:open areadat run-id)
+  (let* ((runs   (areadat-runs areadat))
+	 (rundat (if (> run-id 0) ;; it is a run
+		     (hash-table-ref/default runs run-id #f)
+		     #f))
+	 (db     (case run-id ;; if already opened, get the db and return it
+		   ((-1) (areadat-monitordb areadat))
+		   ((0)  (areadat-maindb    areadat))
+		   (else (if rundat
+			     (rundat-db rundat)
+			     #f)))))
+    (if db
+	db ;; merely return the already opened db
+	(let* ((dbfile (areadb:dbfile-path areadat run-id)) ;; not already opened, so open it
+	       (db     (if (file-exists? dbfile)
+			   (open-database dbfile)
+			   (begin
+			     (debug:print-error 0 *default-log-port* "I was asked to open " dbfile ", but file does not exist or is not readable.")
+			     #f))))
+	  (case run-id
+	    ((-1)(areadat-monitordb-set! areadat db))
+	    ((0) (areadat-maindb-set!    areadat db))
+	    (else (rundat-db-set!        rundat  db)))
+	  db))))
+
+;; populate the areadat tests info, does NOT fill the tests data itself unless asked
+;;
+(define (areadb:populate-run-info areadat)
+  (let* ((runs   (or (areadat-runs areadat) (make-hash-table)))
+	 (keys   (areadat-run-keys areadat))
+	 (maindb (areadb:open areadat 0)))
+    (if maindb
+	(query (for-each-row (lambda (row)
+			       (let ((id  (list-ref row 0))
+				     (dat (apply make-rundat (append row (list #f #f))))) ;; add placeholders for tests and db
+				 (print row)
+				 (hash-table-set! runs id dat))))
+	       (sql maindb (conc "SELECT id,"
+				 (string-intersperse keys "||'/'||")
+				 ",runname,state,status,event_time FROM runs WHERE state != 'deleted';")))
+	(debug:print-error 0 *default-log-port* "no main.db found at "  (areadb:dbfile-path areadat 0)))
+    areadat))
+
+;; given an areadat and target/runname patt fill up runs data
+;;
+;; ?????/
+
+;; given a list of run-ids refresh/retrieve runs data into areadat
+;;
+(define (areadb:fill-tests areadat #!key (run-ids #f))
+  (let* ((runs   (or (areadat-runs areadat) (make-hash-table))))
+    (for-each
+     (lambda (run-id)
+       (let* ((rundat (hash-table-ref/default runs run-id #f))
+	      (tests  (if (and rundat
+			       (rundat-tests rundat)) ;; re-use existing hash table?
+			  (rundat-tests rundat)
+			  (let ((ht (make-hash-table)))
+			    (rundat-tests-set! rundat ht)
+			    ht)))
+	      (rundb  (areadb:open areadat run-id)))
+	 (query (for-each-row (lambda (row)
+				(let* ((id         (list-ref row 0))
+				       (testname   (list-ref row 1))
+				       (itempath   (list-ref row 2))
+				       (state      (list-ref row 3))
+				       (status     (list-ref row 4))
+				       (eventtim   (list-ref row 5))
+				       (duration   (list-ref row 6)))
+				  (hash-table-set! tests id
+						   (make-testdat run-id id testname itempath state status eventtim duration)))))
+		(sql rundb "SELECT id,testname,item_path,state,status,event_time,run_duration FROM tests WHERE state != 'DELETED';"))))
+     (or run-ids (hash-table-keys runs)))
+    areadat))
+    
+
+;; initialize and refresh data
+;;		
+(define (dboard:general-updater con port)
+  (for-each
+   (lambda (window-id)
+     ;; (print "Processing for window-id " window-id)
+     (let* ((window-dat     (hash-table-ref *windows* window-id))
+	    (areas          (data-areas     window-dat))
+	    ;; (keys           (areadat-run-keys area-dat))
+	    (tabs           (data-tabs      window-dat))
+	    (tab-ids        (hash-table-keys tabs))
+	    (current-tab    (if (null? tab-ids)
+				#f
+				(hash-table-ref tabs (car tab-ids))))
+	    (current-tree   (if (null? tab-ids) #f (tab-tree   current-tab)))
+	    (current-node   (if (null? tab-ids) 0  (string->number (iup:attribute current-tree "VALUE"))))
+	    (current-path   (if (eq? current-node 0)
+				"Areas"
+				(string-intersperse (tree:node->path current-tree current-node) "/")))
+	    (current-matrix (if (null? tab-ids) #f (tab-matrix current-tab)))
+	    (seen-nodes     (make-hash-table))
+	    (path-changed   (if current-tab
+				(equal? current-path (tab-view-path current-tab))
+				#t)))
+       ;; (debug:print-info 0 *default-log-port* "Current path: " current-path)
+       ;; now for each area in the window gather the data
+       (if path-changed
+	   (begin
+	     (debug:print-info 0 *default-log-port* "clearing matrix - path changed")
+	     (dboard:clear-matrix current-tab)))
+       (for-each
+	(lambda (area-name)
+	  ;; (print "Processing for area-name " area-name)
+	  (let* ((area-dat  (hash-table-ref areas area-name))
+		 (area-path (areadat-path   area-dat))
+		 (runs      (areadat-runs   area-dat)))
+	    (if (hash-table-ref/default *changed-main* area-path 'processed)
+		(begin
+		  (print "Processing " area-dat " for area-name " area-name)
+		  (hash-table-set! *changed-main* area-path #f)
+		  (areadb:populate-run-info area-dat)
+		  (for-each 
+		   (lambda (run-id)
+		     (let* ((run     (hash-table-ref runs run-id))
+			    (target  (rundat-target run))
+			    (runname (rundat-runname run)))
+		       (if current-tree
+			   (let* ((partial-path (append (string-split target "/")(list runname)))
+				  (full-path    (cons area-name partial-path)))
+			     (if (not (hash-table-exists? seen-nodes full-path))
+				 (begin
+				   (print "INFO: Adding node " partial-path " to section " area-name)
+				   (tree:add-node current-tree "Areas" full-path)
+				   (areadb:fill-tests area-dat run-ids: (list run-id))))
+				   (hash-table-set! seen-nodes full-path #t)))))
+		   (hash-table-keys runs))))
+	    (if (or (equal? "Areas" current-path)
+		    (string-match (conc "^Areas/" area-name "(|\\/.*)$") current-path))
+		(dboard:redraw-area area-name area-dat current-tab current-matrix current-path))))
+	(hash-table-keys areas))))
+   (hash-table-keys *windows*)))
+
+;;======================================================================
+;; D A S H B O A R D   D B 
+;;======================================================================
+
+;; All moved to common.scm		
+
+;;======================================================================
+;; T R E E 
+;;======================================================================
+
+;;  -  -  -  - 
+
+(define (dashboard:tree-browser data adat window-id)
+  ;; (iup:split
+  (let* ((tb      (iup:treebox
+		   #:value 0
+		   #:title "Areas"
+		   #:expand "YES"
+		   #:addexpanded "NO"
+		   #:selection-cb
+		   (lambda (obj id state)
+		     ;; (print "obj: " obj ", id: " id ", state: " state)
+		     (let* ((tree-path (tree:node->path obj id))
+			    (area      (car tree-path))
+			    (areadat-path (cdr tree-path)))
+		       #f
+		       ;; (test-id  (tree-path->test-id (cdr run-path))))
+		       ;; (if test-id
+		       ;;    (hash-table-set! (dboard:data-curr-test-ids *data*)
+		       ;;		     window-id test-id))
+		       ;; (print "path: " (tree:node->path obj id) " test-id: " test-id))))))
+		       )))))
+    ;; (iup:attribute-set! tb "VALUE" "0")
+    ;; (iup:attribute-set! tb "NAME" "Runs")
+    ;; (iup:attribute-set! tb "ADDEXPANDED" "NO")
+    ;; (dboard:data-tests-tree-set! *data* tb)
+    tb))
+
+;;======================================================================
+;; M A I N   M A T R I X
+;;======================================================================
+
+;; General displayer
+;;
+(define (dashboard:main-matrix data adat window-id)
+  (let* (;; (tab-dat         (areadat-
+	 (view-matrix     (iup:matrix
+			   ;; (runs-for-targ (db:get-runs-by-patt *dbstruct-local* *keys* "%" target #f #f #f))
+			   #:expand "YES"
+			   ;; #:fittosize "YES"
+			   #:resizematrix "YES"
+			   #:scrollbar "YES"
+			   #:numcol 100
+			   #:numlin 100
+			   #:numcol-visible 3
+			   #:numlin-visible 20
+			   #:click-cb (lambda (obj lin col status)
+					(print "obj: " obj " lin: " lin " col: " col " status: " status " value: " (iup:attribute obj "VALUE"))))))
+    
+    ;; (iup:attribute-set! view-matrix "RESIZEMATRIX" "YES")
+    (iup:attribute-set! view-matrix "WIDTH0" "100")
+    ;; (dboard:data-runs-matrix-set! *data* runs-matrix)
+    ;; (iup:hbox
+    ;;  (iup:frame 
+    ;;   #:title "Runs browser"
+    ;;   (iup:vbox
+    view-matrix))
+
+;;======================================================================
+;; A R E A S
+;;======================================================================
+
+(define (dashboard:init-area data area-name apath)
+  (let* ((mtconf      (dboard:read-mtconf apath))
+	 (area-dat    (let ((ad (make-areadat
+				 area-name ;; area name
+				 apath     ;; path to area
+				 ;; 'http     ;; transport
+				 mtconf    ;; megatest.config
+				 (make-hash-table) ;; denoise hash
+				 #f        ;; client-signature
+				 #f        ;; remote connections
+				 (keys:config-get-fields mtconf) ;; run keys
+				 (make-hash-table) ;; run-id -> (hash of test-ids => dat)
+				 (and (file-exists? apath)(file-write-access? apath)) ;; read-only
+				 #f
+				 #f
+				 )))
+			(hash-table-set! (data-areas data) area-name ad)
+			ad)))
+    area-dat))
+
+;; given the keys for an area and a path from the tree browser
+;; return the level: areas area runs run tests test
+;;
+(define (dboard:get-view-type keys current-path)
+  (let* ((path-parts (string-split current-path "/"))
+	 (path-len   (length path-parts)))
+    (cond
+     ((equal? current-path "Areas")     'areas)
+     ((eq? path-len 2)                  'area)
+     ((<= (+ (length keys) 2) path-len) 'runs)
+     (else                              'run))))
+
+(define (dboard:clear-matrix tab)
+  (if tab
+      (begin
+	(iup:attribute-set! (tab-matrix tab) "CLEARVALUE" "ALL")
+	(tab-headers-set! tab (make-hash-table))
+	(tab-rows-set!    tab (make-hash-table)))))
+
+;; full redraw of a given area
+;;
+(define (dboard:redraw-area area-name area-dat tab-dat current-matrix current-path)
+  (let* ((keys      (areadat-run-keys area-dat))
+	 (runs      (areadat-runs     area-dat))
+	 (headers   (tab-headers   tab-dat))
+	 (rows      (tab-rows      tab-dat))
+	 (used-cols (hash-table-values headers))
+	 (used-rows (hash-table-values rows))
+	 (touched   (make-hash-table)) ;; (vector row col) ==> true, touched cell
+	 (view-type (dboard:get-view-type keys current-path))
+	 (changed   #f)
+	 (state-statuses  (list "PASS" "FAIL" "WARN" "CHECK" "SKIP" "RUNNING" "LAUNCHED")))
+    ;; (debug:print 0 *default-log-port* "current-matrix=" current-matrix)
+    (case view-type
+      ((areas) ;; find row for this area, if not found, create new entry
+       (let* ((curr-rownum (hash-table-ref/default rows area-name #f))
+	      (next-rownum (+ (apply max (cons 0 used-rows)) 1))
+	      (rownum      (or curr-rownum next-rownum))
+	      (coord       (conc rownum ":0")))
+	 (if (not curr-rownum)(hash-table-set! rows area-name rownum))
+	 (if (not (equal? (iup:attribute current-matrix coord) area-name))
+	     (begin
+	       (let loop ((hed  (car state-statuses))
+			  (tal  (cdr state-statuses))
+			  (count 1))
+		 (if (not (equal? (iup:attribute current-matrix (conc "0:" count)) hed))
+		     (iup:attribute-set! current-matrix (conc "0:" count) hed))
+		 (iup:attribute-set! current-matrix (conc rownum ":" count) "0")
+		 (if (not (null? tal))
+		     (loop (car tal)(cdr tal)(+ count 1))))
+	       (debug:print-info 0 *default-log-port* "view-type=" view-type ", rownum=" rownum ", curr-rownum=" curr-rownum ", next-rownum=" next-rownum ", coord=" coord ", area-name=" area-name)
+	       (iup:attribute-set! current-matrix coord area-name)
+	       (set! changed #t))))))
+    (if changed (iup:attribute-set! current-matrix "REDRAW" "ALL"))))
+	     
+
+       
+   ;; (dboard:clear-matrix current-matrix used-cols used-rows touched) ;; clear all
+    
+	
+  
+;;======================================================================
+;; D A S H B O A R D
+;;======================================================================
+
+(define (dashboard:area-panel aname data window-id)
+  (let* ((apath      (configf:lookup (data-cfgdat data) aname "path")) ;;  (hash-table-ref (dboard:data-cfgdat data) area-name))
+	 ;;          (hash-table-ref (dboard:data-cfgdat data) aname))
+	 (area-dat   (dashboard:init-area data aname apath))
+	 (tb         (dashboard:tree-browser data area-dat window-id)) ;; (dboard:areas-tree-browser data)
+	 (ad         (dashboard:main-matrix  data area-dat window-id))
+	 (areas      (data-areas data))
+	 (dboard-dat (make-tab
+		      #f           ;; tree
+		      #f           ;; matrix
+		      area-dat     ;;
+		      #f           ;; view path
+		      'default     ;; view type
+		      #f           ;; controls
+		      (make-hash-table) ;; cached data? not sure how to use this yet :)
+		      #f           ;; filters
+		      #f           ;; the run-id
+		      (make-hash-table) ;; run-id -> test-id, for current test id
+		      ""
+		      (make-hash-table) ;; headername -> colnum
+		      (make-hash-table) ;; rowname    -> rownum
+		      )))
+    (hash-table-set! (data-areas data) aname area-dat) ;; dboard-dat)
+    (hash-table-set! (data-tabs data) window-id dboard-dat)
+    (tab-tree-set!   dboard-dat tb)
+    (tab-matrix-set! dboard-dat ad)
+    (iup:split
+     #:value 200
+     tb ad)))
+
+
+;; Main Panel
+;;
+(define (dashboard:main-panel data window-id)
+  (iup:dialog
+   #:title "Megatest Control Panel"
+;;   #:menu (dcommon:main-menu data)
+   #:shrink "YES"
+   (iup:vbox
+    (let* ((area-names  (hash-table-keys (data-cfgdat data)))
+	   (area-panels (map (lambda (aname)
+			       (dashboard:area-panel aname data window-id))
+			     area-names))
+	   (tabtop      (apply iup:tabs  
+			       #:tabchangepos-cb (lambda (obj curr prev)
+						   (data-current-tab-id-set! data curr)
+						   (data-update-needed-set!  data #t)
+						   (print "Tab is: " curr ", prev was " prev))
+			       area-panels))
+	   (tabs     (data-tabs data)))
+      (if (not (null? area-names))
+	  (let loop ((index 0)
+		     (hed   (car area-names))
+		     (tal   (cdr area-names)))
+	    ;; (hash-table-set! tabs index hed)
+	    (debug:print 0 *default-log-port* "Adding area " hed " with index " index " to dashboard")
+	    (iup:attribute-set! tabtop (conc "TABTITLE" index) hed)
+	    (if (not (null? tal))
+		(loop (+ index 1)(car tal)(cdr tal)))))
+      tabtop))))
+
+
+;;======================================================================
+;; N A N O M S G   S E R V E R
+;;======================================================================
+
+(define (dboard:server-service soc port)
+  (print "server starting")
+  (let loop ((msg-in (nn-recv soc))
+	     (count  0))
+    (if (eq? 0 (modulo count 1000))
+	(print "server received: " msg-in ", count=" count))
+    (cond
+     ;;
+     ;; quit
+     ;;
+     ((equal? msg-in "quit")
+      (nn-send soc "Ok, quitting"))
+     ;;
+     ;; ping
+     ;;
+     ((and (>= (string-length msg-in) 4)
+	   (equal? (substring msg-in 0 4) "ping"))
+      (nn-send soc (conc (current-process-id)))
+      (loop (nn-recv soc)(+ count 1)))
+     ;;
+     ;; main changed
+     ;;
+     ((and (>= (string-length msg-in) 4)
+	   (equal? (substring msg-in 0 4) "main"))
+      (let ((parts (string-split msg-in " ")))
+	(hash-table-set! *changed-main* (cadr parts) #t)
+	(nn-send soc "got it!")))
+     ;;
+     ;; ??
+     ;;
+     (else
+      (nn-send soc "hello " msg-in " you got to the else clause!")))
+    (loop (nn-recv soc)(if (> count 20000000)
+			   0
+			   (+ count 1)))))
+
+(define (dboard:one-time-ping-receive soc port)
+  (let ((msg-in (nn-recv soc)))
+    (if (and (>= (string-length msg-in) 4)
+	     (equal? (substring msg-in 0 4) "ping"))
+	(nn-send soc (conc (current-process-id))))))
+
+(define (dboard:server-start given-port #!key (num-tries 200))
+  (let* ((rep (nn-socket 'rep))
+	 (port (or given-port  (portlogger:main "find")))
+	 (con (conc "tcp://*:" port)))
+    ;; register this connect here ....
+    (nn-bind rep con)
+    (thread-start! 
+     (make-thread (lambda ()
+		    (dboard:one-time-ping-receive rep port))
+		  "one time receive thread"))
+    (if (dboard:ping-self "localhost" port)
+	(begin
+	  (print "INFO: dashboard nanomsg server started on " port)
+	  (values rep port))
+	(begin
+	  (print "WARNING: couldn't create server on port " port)
+	  (portlogger:main "set" "failed")
+	  (if (> num-tries 0)
+	      (dboard:server-start #f (- num-tries 1))
+	      (begin
+		(print "ERROR: failed to start nanomsg server")
+		(values #f #f)))))))
+
+(define (dboard:server-close con port)
+  (nn-close con)
+  (portlogger:main "set" port "released"))
+
+(define (dboard:ping-self host port #!key (return-socket #t))
+  ;; send a random number along with pid and check that we get it back
+  (let* ((req     (nn-socket 'req))
+	 (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")))
+    (nn-connect req (conc "tcp://" host ":" port))
+    (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 " host ":" port))
+     (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))))
+
+;;======================================================================
+;; C O N F I G U R A T I O N 
+;;======================================================================
+
+;; Get the configuration file for a group name, if the group name is "default" and it doesn't 
+;; exist, create it and add the current path if it contains megatest.config
+;;
+(define (dboard:get-config group-name)
+  (let* ((fname (conc (getenv "HOME") "/.megatest/" group-name ".dat")))
+    (if (file-exists? fname)
+	(read-config fname (make-hash-table) #t)
+	(if (dboard:create-config fname)
+	    (dboard:get-config group-name)
+	    (make-hash-table)))))
+
+(define (dboard:create-config fname)
+  ;; (handle-exceptions
+  ;;  exn
+  ;;  
+  ;;  #f ;; failed to create - just give up
+   (let* ((dirname       (pathname-directory fname))
+	  (file-name     (pathname-strip-directory fname))
+	  (curr-mtcfgdat (find-config "megatest.config"
+				      toppath: (or (get-environment-variable "MT_RUN_AREA_HOME")(current-directory))))
+	  (curr-mtcfg    (if (and curr-mtcfgdat (not (null? curr-mtcfgdat)))(cadr curr-mtcfgdat) #f))
+	  (curr-mtpath   (if curr-mtcfg (car curr-mtcfgdat) #f)))
+     (if curr-mtpath
+	 (begin
+	   (debug:print-info 0 *default-log-port* "Creating config file " fname)
+	   (if (not (file-exists? dirname))
+	       (create-directory dirname #t))
+	   (with-output-to-file fname
+	     (lambda ()
+	       (let ((aname (pathname-strip-directory curr-mtpath)))
+		 (print "[" aname "]")
+		 (print  "path " curr-mtpath))))
+	   #t)
+	 (begin
+	   (debug:print-info 0 *default-log-port* "Need to create a config but no megatest.config found: " curr-mtcfgdat)
+	   #f))))
+;; )
+
+(define (dboard:read-mtconf apath)
+  (let* ((mtconffile  (conc apath "/megatest.config")))
+    (call-with-environment-variables
+     (list (cons "MT_RUN_AREA_HOME" apath))
+     (lambda ()
+       (read-config mtconffile (make-hash-table) #f)) ;; megatest.config
+     )))
+	 
+
+;;======================================================================
+;; G U I   S T U F F 
+;;======================================================================
+
+;;; main. Theoretically could have multiple windows (each with a group of tags, thus window-id
+;;;
+(define (dboard:make-window window-id)
+  (let* (;; (window-id 0)
+	 (groupn    (or (args:get-arg "-group") "default"))
+	 (cfgdat    (dboard:get-config groupn))
+	 ;; (cfgdat    (if (file-exists? cfname)(read-config cfname (make-hash-table) #t)(make-hash-table)))
+	 (data      (make-data
+		     cfgdat ;; this is the data from ~/.megatest for the selected group
+		     (make-hash-table) ;; areaname -> area-rec
+		     0                 ;; current window id
+		     0                 ;; current tab id
+		     #f                ;; redraw needed for current tab id
+		     (make-hash-table) ;; tab-id -> areaname
+		     )))
+    (hash-table-set! *windows* window-id data)
+    (iup:show (dashboard:main-panel data window-id))
+    (iup:main-loop)))
+
+;; ease debugging by loading ~/.dashboardrc
+(let ((debugcontrolf (conc (get-environment-variable "HOME") "/.dashboardrc")))
+  (if (file-exists? debugcontrolf)
+      (load debugcontrolf)))
+
+(define (main)
+  (let-values 
+      (((con port)(dboard:server-start #f)))
+    (let ((portnum   (if (string? port)(string->number port) port)))
+      ;; got here, monitor/dashboard was started
+      (mddb:register-dashboard portnum)
+      (thread-start! (make-thread (lambda ()(dboard:server-service con portnum)) "server service"))
+      (thread-start! (make-thread (lambda ()
+				    (let loop ()
+				      (dboard:general-updater con portnum)
+				      (thread-sleep! 1)
+				      (loop))) "general updater"))
+      (dboard:make-window 0)
+      (mddb:unregister-dashboard (get-host-name) portnum)
+      (dboard:server-close con port))))
+

Index: oldsrc/newdashboard.scm
==================================================================
--- oldsrc/newdashboard.scm
+++ oldsrc/newdashboard.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 numbers)
 (require-library iup)
 (import (prefix iup iup:))

ADDED   oldsrc/nmsg-transport.scm
Index: oldsrc/nmsg-transport.scm
==================================================================
--- /dev/null
+++ oldsrc/nmsg-transport.scm
@@ -0,0 +1,358 @@
+
+;; 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 program is distributed WITHOUT ANY WARRANTY; without even the
+;;  implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
+;;  PURPOSE.
+
+(require-extension (srfi 18) extras tcp s11n)
+
+(use sqlite3 srfi-1 posix regex regex-case srfi-69 hostinfo md5 message-digest)
+(import (prefix sqlite3 sqlite3:))
+
+;; (use nanomsg)
+
+(declare (unit nmsg-transport))
+
+(declare (uses common))
+(declare (uses db))
+(declare (uses tests))
+(declare (uses tasks)) ;; tasks are where stuff is maintained about what is running.
+(declare (uses server))
+
+(include "common_records.scm")
+(include "db_records.scm")
+
+;; Transition to pub --> sub with pull <-- push
+;;
+;;   1. client sends request to server via push to the pull port
+;;   2. server puts request in queue or processes immediately as appropriate
+;;   3. server puts responses from completed requests into pub port 
+;;
+;; TODO
+;;
+;; Done Tested
+;; [x]  [ ]    1. Add columns pullport pubport to servers table
+;; [x]  [ ]    2. Add rm of monitor.db if older than 11/12/2012 
+;; [x]  [ ]    3. Add create of pullport and pubport with finding of available ports
+;; [x]  [ ]    4. Add client compose of request
+;; [x]  [ ]        - name of client: testname/itempath-test_id-hostname 
+;; [x]  [ ]        - name of request: callname, params
+;; [x]  [ ]        - request key: f(clientname, callname, params)
+;; [x]  [ ]    5. Add processing of subscription hits
+;; [x]  [ ]        - done when get key 
+;; [x]  [ ]        - return results
+;; [x]  [ ]    6. Add timeout processing
+;; [x]  [ ]        - after 60 seconds
+;; [ ]  [ ]            i. check server alive, connect to new if necessary
+;; [ ]  [ ]           ii. resend request
+;; [ ]  [ ]    7. Turn self ping back on
+
+(define (nmsg-transport:make-server-url hostport #!key (bindall #f))
+  (if (not hostport)
+      #f
+      (conc "tcp://" (if bindall "*" (car hostport)) ":" (cadr hostport))))
+
+(define *server-loop-heart-beat* (current-seconds))
+(define *heartbeat-mutex* (make-mutex))
+
+;;======================================================================
+;; S E R V E R
+;;======================================================================
+
+(define (nmsg-transport:run dbstruct hostn run-id server-id #!key (retrynum 1000))
+  (debug:print 2 *default-log-port* "Attempting to start the server ...")
+  (let* ((start-port      (portlogger:open-run-close portlogger:find-port))
+	 (server-thread   (make-thread (lambda ()
+					 (nmsg-transport:try-start-server dbstruct run-id start-port server-id))
+				       "server thread"))
+	 (tdbdat          (tasks:open-db)))
+    (thread-start! server-thread)
+    (thread-sleep! 0.1)
+    (if (nmsg-transport:ping hostn start-port timeout: 2 expected-key: (current-process-id))
+	(let ((interface (if (equal? hostn "-")(get-host-name) hostn)))
+	  (tasks:server-set-interface-port (db:delay-if-busy tdbdat) server-id interface start-port)
+	  (tasks:server-set-state! (db:delay-if-busy tdbdat) server-id "dbprep")
+	  (set! *server-info* (list hostn start-port)) ;; probably not needed anymore? currently used by keep-running
+	  (thread-sleep! 3) ;; give some margin for queries to complete before switching from file based access to server based access
+	  ;; (set! *inmemdb*  dbstruct)
+	  (tasks:server-set-state! (db:delay-if-busy tdbdat) server-id "running")
+	  (thread-start! (make-thread
+			  (lambda ()(nmsg-transport:keep-running server-id run-id))
+			  "keep running"))
+	  (thread-join! server-thread))
+	(if (> retrynum 0)
+	    (begin
+	      (debug:print 0 *default-log-port* "WARNING: Failed to connect to server (self) on host " hostn ":" start-port ", trying again.")
+	      (tasks:server-delete-record (db:delay-if-busy tdbdat) server-id "failed to start, never received server alive signature")
+	      (portlogger:open-run-close portlogger:set-failed start-port)
+	      (nmsg-transport:run dbstruct hostn run-id server-id))
+	    (begin
+	      (debug:print-error 0 *default-log-port* "could not find an open port to start server on. Giving up")
+	      (exit 1))))))
+
+(define (nmsg-transport:try-start-server dbstruct run-id portnum server-id)
+  (let ((repsoc (nn-socket 'rep)))
+    (nn-bind repsoc (conc "tcp://*:" portnum))
+    (let loop ((msg-in (nn-recv repsoc)))
+      (let* ((dat    (db:string->obj msg-in transport: 'nmsg)))
+	(debug:print 0 *default-log-port* "server, received: " dat)
+	(let ((result (api:execute-requests dbstruct dat)))
+	  (debug:print 0 *default-log-port* "server, sending: " result)
+	  (nn-send repsoc (db:obj->string result  transport: 'nmsg)))
+	(loop (nn-recv repsoc))))))
+
+;; all routes though here end in exit ...
+;;
+(define (nmsg-transport:launch run-id)
+  (let* ((tdbdat   (tasks:open-db))
+	 (dbstruct (db:setup run-id))
+	 (hostn    (or (args:get-arg "-server") "-")))
+    (set! *run-id*   run-id)
+    (set! *inmemdb* dbstruct)
+    ;; with nbfake daemonize isn't really needed
+    ;;
+    ;; (if (args:get-arg "-daemonize")
+    ;;     (begin
+    ;;       (daemon:ize)
+    ;;       (if *alt-log-file* ;; we should re-connect to this port, I think daemon:ize disrupts it
+    ;;           (begin
+    ;;     	(current-error-port *alt-log-file*)
+    ;;     	(current-output-port *alt-log-file*)))))
+    (if (server:check-if-running run-id)
+	(begin
+	  (debug:print-info 0 *default-log-port* "Server for run-id " run-id " already running")
+	  (exit 0)))
+    (let loop ((server-id (tasks:server-lock-slot (db:delay-if-busy tdbdat) run-id))
+	       (remtries  4))
+      (if (not server-id)
+	  (if (> remtries 0)
+	      (begin
+		(thread-sleep! 2)
+		(if (not (server:check-if-running run-id))
+		    (loop (tasks:server-lock-slot (db:delay-if-busy tdbdat) run-id)
+			  (- remtries 1))
+		    (begin
+		      (debug:print-info 0 *default-log-port* "Another server took the slot, exiting")
+		      (exit 0))))
+	      (begin
+		;; since we didn't get the server lock we are going to clean up and bail out
+		(debug:print-info 2 *default-log-port* "INFO: server pid=" (current-process-id) ", hostname=" (get-host-name) " not starting due to other candidates ahead in start queue")
+		(tasks:server-delete-records-for-this-pid (db:delay-if-busy tdbdat) " http-transport:launch")
+		))
+	  ;; locked in a server id, try to start up
+	  (nmsg-transport:run dbstruct hostn run-id server-id))
+      (set! *didsomething* #t)
+      (exit))))
+
+;;======================================================================
+;; S E R V E R   U T I L I T I E S 
+;;======================================================================
+
+(define (nmsg-transport:mk-signature)
+  (message-digest-string (md5-primitive) 
+			 (with-output-to-string
+			   (lambda ()
+			     (write (list (current-directory)
+					  (argv)))))))
+
+;;======================================================================
+;; C L I E N T S
+;;======================================================================
+
+;; ping the server at host:port
+;;   return the open socket if successful (return-socket == #t)
+;;   expect the key expected-key returned in payload
+;;   send our-key or #f as payload
+;;
+(define (nmsg-transport:ping hostn port #!key (timeout 3)(return-socket #t)(expected-key #f)(our-key #f)(socket #f))
+  ;; send a random number along with pid and check that we get it back
+  (let* ((host    (if (or (not hostn)
+			  (equal? hostn "-")) ;; use localhost
+		      (get-host-name)
+		      hostn))
+	 (req     (or socket
+		      (let ((soc (nn-socket 'req)))
+			(nn-connect soc (conc "tcp://" host ":" port))
+			soc)))
+	 (success #t)
+	 (dat     (vector "ping" our-key))
+	 (result  (condition-case 
+		   (nmsg-transport:client-api-send-receive-raw req dat timeout: timeout)
+		   ((timeout)(set! success #f) #f)))
+	 (key     (if success 
+		      (vector-ref result 1)
+		      #f)))
+    (debug:print 0 *default-log-port* "success=" success ", key=" key ", expected-key=" expected-key ", equal? " (equal? key expected-key))
+    (if (and success
+	     (or (not expected-key) ;; just getting a reply is good enough then
+		 (equal? key expected-key)))
+	(if return-socket
+	    req
+	    (begin
+	      (if (not socket)(nn-close req)) ;; don't want a side effect of closing socket if handed it
+	      #t))
+	(begin
+	  (if (not socket)(nn-close req)) ;; failed to ping, close socket as side effect
+	  #f))))
+
+;; send data to server, wait max of timeout seconds for a response.
+;; return #( success/fail result )
+;;
+;; for effiency it is easier to do the obj->string and string->obj here.
+;;
+(define (nmsg-transport:client-api-send-receive-raw socreq indat #!key (enable-send #t)(timeout 25))
+  (let* ((success     #f)
+	 (result      #f)
+	 (keepwaiting #t)
+	 (dat         (db:obj->string indat transport: 'nmsg))
+	 (send-recv   (make-thread
+		       (lambda ()
+			 (nn-send socreq dat)
+			 (let* ((res (nn-recv socreq)))
+			   (set! success #t)
+			   (set! result (db:string->obj res transport: 'nmsg))))
+		       "send-recv"))
+	 (timeout     (make-thread
+		       (lambda ()
+			 (let loop ((count 0))
+			   (thread-sleep! 1)
+			   (debug:print-info 1 *default-log-port* "send-receive-raw, still waiting after " count " seconds...")
+			   (if (and keepwaiting (< count timeout)) ;; yes, this is very aproximate
+			       (loop (+ count 1))))
+			 (if keepwaiting
+			     (begin
+			       (print "timeout waiting for ping")
+			       (thread-terminate! send-recv))))
+		       "timeout")))
+    ;; replace with condition-case?
+    (handle-exceptions
+     exn
+     (set! result "timeout")
+     (thread-start! timeout)
+     (thread-start! send-recv)
+     (thread-join! send-recv)
+     (if success (thread-terminate! timeout)))
+    ;; raise timeout error if timed out
+    (if success
+	(if (and (vector? result)
+		 (vector-ref result 0)) ;; did it fail at the server?
+	    result                ;; nope, all good
+	    (begin
+	      (debug:print-error 0 *default-log-port* "error occured at server, info=" (vector-ref result 2))
+	      (debug:print 0 *default-log-port* " client call chain:")
+	      (print-call-chain (current-error-port))
+	      (debug:print 0 *default-log-port* " server call chain:")
+	      (pp (vector-ref result 1) (current-error-port))
+	      (signal (vector-ref result 0))))
+	(signal (make-composite-condition
+		 (make-property-condition 'timeout 'message "nmsg-transport:client-api-send-receive-raw timed out talking to server"))))))
+
+;; run nmsg-transport:keep-running in a parallel thread to monitor that the db is being 
+;; used and to shutdown after sometime if it is not.
+;;
+(define (nmsg-transport:keep-running server-id run-id)
+  ;; if none running or if > 20 seconds since 
+  ;; server last used then start shutdown
+  ;; This thread waits for the server to come alive
+  (let* ((server-info (let loop ()
+                        (let ((sdat #f))
+                          (mutex-lock! *heartbeat-mutex*)
+                          (set! sdat *server-info*)
+                          (mutex-unlock! *heartbeat-mutex*)
+                          (if sdat 
+			      (begin
+				(debug:print-info 0 *default-log-port* "keep-running got sdat=" sdat)
+				sdat)
+                              (begin
+                                (thread-sleep! 0.5)
+                                (loop))))))
+         (iface       (car server-info))
+         (port        (cadr server-info))
+         (last-access 0)
+	 (tdbdat      (tasks:open-db))
+	 (server-timeout (let ((tmo (configf:lookup  *configdat* "server" "timeout")))
+			   (if (and (string? tmo)
+				    (string->number tmo))
+			       (* 60 60 (string->number tmo))
+			       ;; (* 3 24 60 60) ;; default to three days
+			       (* 60 1)         ;; default to one minute
+			       ;; (* 60 60 25)      ;; default to 25 hours
+			       ))))
+    (print "Keep-running got server pid " server-id ", using iface " iface " and port " port)
+    (let loop ((count 0))
+      (thread-sleep! 4) ;; no need to do this very often
+      ;; NB// sync currently does NOT return queue-length
+      (let () ;; (queue-len (cdb:client-call server-info 'sync #t 1)))
+      ;; (print "Server running, count is " count)
+        (if (< count 1) ;; 3x3 = 9 secs aprox
+            (loop (+ count 1)))
+        
+        (mutex-lock! *heartbeat-mutex*)
+        (set! last-access *last-db-access*)
+        (mutex-unlock! *heartbeat-mutex*)
+	(db:sync-touched *inmemdb* run-id force-sync: #t)
+        (if (and *server-run*
+	       (> (+ last-access server-timeout)
+		  (current-seconds)))
+            (begin
+              (debug:print-info 0 *default-log-port* "Server continuing, seconds since last db access: " (- (current-seconds) last-access))
+              (loop 0))
+            (begin
+              (debug:print-info 0 *default-log-port* "Starting to shutdown the server.")
+              (set! *time-to-exit* #t)
+	      (db:sync-touched *inmemdb* run-id force-sync: #t)
+              (tasks:server-delete-record (db:delay-if-busy tdbdat) server-id " http-transport:keep-running")
+              (debug:print-info 0 *default-log-port* "Server shutdown complete. Exiting")
+              (exit)
+	      ))))))
+
+;;======================================================================
+;; C L I E N T S
+;;======================================================================
+
+(define (nmsg-transport:client-connect iface portnum)
+  (let* ((reqsoc      (nmsg-transport:ping iface portnum return-socket: #t)))
+    (vector iface portnum #f #f #f (current-seconds) reqsoc)))
+
+;; returns result, there is no sucess/fail flag - handled via excpections
+;;
+(define (nmsg-transport:client-api-send-receive run-id connection-info cmd param #!key (remtries 5))
+  ;; NB// In the html version of this routine there is a call to 
+  ;;      tasks:kill-server-run-id when there is an exception
+  (mutex-lock! *http-mutex*)
+  (let* ((packet  (vector cmd param))
+	 (reqsoc  (http-transport:server-dat-get-socket connection-info))
+	 (res     (nmsg-transport:client-api-send-receive-raw reqsoc packet)))
+;;	 (status  (vector-ref rawres 0))
+;;	 (result  (vector-ref rawres 1)))
+    (mutex-unlock! *http-mutex*)
+    res)) ;; (vector status (if status (db:string->obj result transport: 'nmsg) result))))
+	
+;;======================================================================
+;; J U N K 
+;;======================================================================
+
+;; DO NOT USE
+;;
+(define (nmsg-transport:client-signal-handler signum)
+  (handle-exceptions
+   exn
+   (debug:print 0 *default-log-port* " ... exiting ...")
+   (let ((th1 (make-thread (lambda ()
+			     (if (not *received-response*)
+				 (receive-message* *runremote*))) ;; 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! 3) ;; give the flush three seconds 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))))
+

Index: oldsrc/zmq-transport.scm
==================================================================
--- oldsrc/zmq-transport.scm
+++ oldsrc/zmq-transport.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 .
+;;
 ;;======================================================================
 
 (require-extension (srfi 18) extras tcp s11n)
 
 (use sqlite3 srfi-1 posix regex regex-case srfi-69 hostinfo md5 message-digest)

Index: portlogger.scm
==================================================================
--- portlogger.scm
+++ portlogger.scm
@@ -1,14 +1,23 @@
 
 ;; 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 .
+;;
 
 (require-extension (srfi 18) extras tcp s11n)
 
 (use sqlite3 srfi-1 posix srfi-69 hostinfo dot-locking z3)
 (import (prefix sqlite3 sqlite3:))
@@ -19,11 +28,11 @@
 ;; lsof -i
 
 
 (define (portlogger:open-db fname)
   (let* ((avail    (tasks:wait-on-journal fname 5 remove: #t)) ;; wait up to about 10 seconds for the journal to go away
-	 (exists   (file-exists? fname))
+	 (exists   (common:file-exists? fname))
 	 (db       (if avail 
 		       (sqlite3:open-database fname)
 		       (begin
 			 (system (conc "rm -f " fname))
 			 (sqlite3:open-database fname))))
@@ -56,12 +65,12 @@
      exn
      (begin
        ;; (release-dot-lock fname)
        (debug:print-error 0 *default-log-port* "portlogger:open-run-close failed. " proc " " params)
        (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
-       (debug:print 0 *default-log-port* "exn=" (condition->list exn))
-       (if (file-exists? fname)(delete-file fname)) ;; brutally get rid of it
+       (debug:print 5 *default-log-port* "exn=" (condition->list exn))
+       (if (common:file-exists? fname)(delete-file fname)) ;; brutally get rid of it
        (print-call-chain (current-error-port)))
      (let* (;; (lock   (obtain-dot-lock fname 2 9 10))
 	    (db     (portlogger:open-db fname))
 	    (res    (apply proc db params)))
        (sqlite3:finalize! db)
@@ -103,11 +112,11 @@
   (handle-exceptions
       exn
       (begin
 	(debug:print 0 *default-log-port* "EXCEPTION: portlogger database probably overloaded or unreadable. If you see this message again remove /tmp/.$USER-portlogger.db")
 	(debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
-	(debug:print 0 *default-log-port* "exn=" (condition->list exn))
+	(debug:print 5 *default-log-port* "exn=" (condition->list exn))
 	(print-call-chain (current-error-port))
 	(debug:print 0 *default-log-port* "Continuing anyway.")
 	#f)
     (sqlite3:fold-row
      (lambda (var curr)
@@ -128,11 +137,11 @@
     (handle-exceptions
      exn
      (begin
        (debug:print 0 *default-log-port* "EXCEPTION: portlogger database probably overloaded or unreadable. If you see this message again remove /tmp/.$USER-portlogger.db")
        (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
-       (debug:print 0 *default-log-port* "exn=" (condition->list exn))
+       (debug:print 5 *default-log-port* "exn=" (condition->list exn))
        (print-call-chain (current-error-port))
        (debug:print 0 *default-log-port* "Continuing anyway."))
      (portlogger:take-port db portnum))
     portnum))
 
@@ -158,11 +167,11 @@
 	  (handle-exceptions
 	   exn
 	   (begin
 	     (debug:print 0 *default-log-port* "EXCEPTION: portlogger database at " dbfname " probably overloaded or unreadable. Try removing it.")
 	     (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))
 	     #f)
 	   (case (string->symbol (car args)) ;; commands with two or more params
 	     ((take)(portlogger:take-port db (string->number (cadr args))))

Index: process.scm
==================================================================
--- process.scm
+++ process.scm
@@ -13,11 +13,10 @@
 ;; Process convience utils
 ;;======================================================================
 
 (use regex)
 (declare (unit process))
-;;(declare (uses common))
 
 (define (process:conservative-read port)
   (let loop ((res ""))
     (if (not (eof-object? (peek-char port)))
 	(loop (conc res (read-char port)))
@@ -46,18 +45,44 @@
 	     (close-input-port fh)
 	     (close-input-port fhe)
 	     (close-output-port fho)
 	     result))))) ;; )
 
+(define (process:cmd-run-with-stderr-and-exitcode->list cmd . params)
+  ;; (print "Called with cmd=" cmd ", proc=" proc ", params=" params)
+;;  (handle-exceptions
+;;   exn
+;;   (begin
+;;     (print "ERROR:  Failed to run command: " cmd " " (string-intersperse params " "))
+;;     (print "       " ((condition-property-accessor 'exn 'message) exn))
+;;     #f)
+   (let-values (((fh fho pid fhe) (if (null? params)
+				      (process* cmd)
+				      (process* cmd params))))
+       (let loop ((curr (read-line fh))
+		  (result  '()))
+	 (let ((errstr (process:conservative-read fhe)))
+	   (if (not (string=? errstr ""))
+	       (set! result (append result (list errstr)))))
+       (if (not (eof-object? curr))
+	   (loop (read-line fh)
+		 (append result (list curr)))
+	   (begin
+	     ;(close-input-port fh)
+	     ;(close-input-port fhe)
+	     ;(close-output-port fho)
+             (let-values (((anotherpid normalexit? exitstatus)  (process-wait pid)))
+               (list result (if normalexit? exitstatus -1))))))))
+
 (define (process:cmd-run-proc-each-line cmd proc . params)
   ;; (print "Called with cmd=" cmd ", proc=" proc ", params=" params)
   (handle-exceptions
    exn
    (begin
      (print "ERROR:  Failed to run command: " cmd " " (string-intersperse params " "))
      (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))
      #f)
    (let-values (((fh fho pid) (if (null? params)
 				  (process cmd)
 				  (process cmd params))))
        (let loop ((curr (read-line fh))
@@ -75,16 +100,19 @@
   (let* ((fh (open-input-pipe cmd))
          (res (port-proc->list fh proc))
          (status (close-input-pipe fh)))
     (if (eq? status 0) res #f)))
 
-(define (process:cmd-run->list cmd)
-  (let* ((fh (open-input-pipe cmd))
-         (res (port->list fh))
-         (status (close-input-pipe fh)))
-    (list res status)))
-
+(define (process:cmd-run->list cmd #!key (delta-env-alist-or-hash-table '()))
+  (common:with-env-vars
+   delta-env-alist-or-hash-table
+   (lambda ()
+     (let* ((fh (open-input-pipe cmd))
+            (res (port->list fh))
+            (status (close-input-pipe fh)))
+       (list res status)))))
+   
 (define (port->list fh)
   (if (eof-object? fh) #f
       (let loop ((curr (read-line fh))
                  (result '()))
         (if (not (eof-object? curr))
@@ -143,11 +171,11 @@
 
 (define (process:alive? pid)
   (handle-exceptions
    exn
    ;; possibly pid is a process not a child, look in /proc to see if it is running still
-   (file-exists? (conc "/proc/" pid))
+   (common:file-exists? (conc "/proc/" pid))
    (let-values (((rpid exit-type exit-signal)(process-wait pid #t)))
        (and (number? rpid)
 	    (equal? rpid pid)))))
 
 (define (process:alive-on-host? host pid)

Index: records.sh
==================================================================
--- records.sh
+++ records.sh
@@ -7,10 +7,29 @@
 #
 # Add -safe when doing development
 #
 export MODE='-safe'
 (echo ";; Created by records.sh. DO NOT EDIT THIS FILE. Edit records.sh instead"
+
+ echo <.
+;;
+EOF
+ 
 make-vector-record $MODE vg lib     comps
 make-vector-record $MODE vg comp    objs name file
 make-vector-record $MODE vg obj     type pts fill-color text line-color call-back angle font attrib extents proc
 make-vector-record $MODE vg inst    libname compname theta xoff yoff scalex scaley mirrx mirry call-back cache
 make-vector-record $MODE vg drawing libs insts scalex scaley xoff yoff cnv cache

DELETED remotediff-nmsg.scm
Index: remotediff-nmsg.scm
==================================================================
--- remotediff-nmsg.scm
+++ /dev/null
@@ -1,187 +0,0 @@
-(use posix)
-(use regex)
-(use directory-utils)
-(use srfi-18 srfi-69 nanomsg)
-
-(define (client-send-receive soc msg)
-  (nn-send soc msg)
-  (nn-recv soc))
-
-;;do as calling user
-(define (do-as-calling-user proc)
-  (let ((eid (current-effective-user-id))
-        (cid (current-user-id)))
-    (if (not (eq? eid cid)) ;; running suid
-        (set! (current-effective-user-id) cid))
-    (proc)
-    (if (not (eq? eid cid))
-        (set! (current-effective-user-id) eid))))
-
-;; use mutex to not open/close files at same time
-;;
-(define (checksum mtx file #!key (cmd "shasum"))
-  (mutex-lock! mtx)
-  (let-values (((inp oup pid)
-                (process cmd (list file))))
-    (mutex-unlock! mtx)
-    (let ((result (read-line inp)))
-      ;; now flush out remaining output
-      (let loop ((inl (read-line inp)))
-        (if (eof-object? inl)
-            (if (string? result)
-                (begin
-                  (mutex-lock! mtx)
-                  (close-input-port inp)
-                  (close-output-port oup)
-                  (mutex-unlock! mtx)
-                  (car (string-split result)))
-                #f)
-            (loop (read-line inp)))))))
-
-(define *max-running* 40)
-
-(define my-mutex-lock! conc)
-(define my-mutex-unlock! conc)
-;; (define my-mutex-lock! mutex-lock!)
-;; (define my-mutex-unlock! mutex-unlock!)
-
-(define (gather-dir-info path)
-  (let ((mtx1     (make-mutex))
-        (threads  (make-hash-table))
-        (last-num 0)
-        (req      (nn-socket 'req)))
-    (print "starting client with pid " (current-process-id))
-    (nn-connect req
-                ;; "tcp://localhost:5559")
-                "ipc:///tmp/test-ipc")
-    (find-files 
-     path 
-     ;; test: #t
-     action: (lambda (p res)
-               (let ((info (cond
-                            ((not (file-read-access? p)) '(cant-read))
-                            ((directory? p)              '(dir))
-                            ((symbolic-link? p)          (list 'symlink (read-symbolic-link p)))
-                            (else                        '(data)))))
-                 (if (eq? (car info) 'data)
-                     (let loop ((start-time (current-seconds)))
-                       (my-mutex-lock! mtx1)
-                       (let* ((num-threads (hash-table-size threads))
-                              (ok-to-run   (> *max-running* num-threads)))
-                         ;; (if (> (abs (- num-threads last-num)) 2)
-                         ;;     (begin
-                         ;;       ;; (print "num-threads:" num-threads)
-                         ;;       (set! last-num num-threads)))
-                         (my-mutex-unlock! mtx1)
-                         (if ok-to-run
-                             (let ((run-time-start (current-seconds)))
-                               ;; (print "num threads: " num-threads)
-                               (let ((th1  (make-thread
-                                            (lambda ()
-                                              (let ((cksum (checksum mtx1 p cmd: "md5sum"))
-                                                    (run-time (- (current-seconds) run-time-start)))
-                                                (my-mutex-lock! mtx1)
-                                                (client-send-receive req (conc p " " cksum))
-                                                (my-mutex-unlock! mtx1))
-                                              (let loop2 ()
-                                                (my-mutex-lock! mtx1)
-                                                (let ((registered (hash-table-exists? threads p)))
-                                                  (if registered
-                                                      (begin
-                                                        ;; (print "deleting thread reference for " p)
-                                                        (hash-table-delete! threads p))) ;; delete myself
-                                                  (my-mutex-unlock! mtx1)
-                                                  (if (not registered)
-                                                      (begin
-                                                        (thread-sleep! 0.5)
-                                                        (loop2))))))
-                                            p)))
-                                 (thread-start! th1)
-                                 ;; (thread-sleep! 0.05) ;; give things a little time to get going
-                                 ;; (thread-join! th1) ;; 
-                                 (my-mutex-lock! mtx1)
-                                 (hash-table-set! threads p th1)
-                                 (my-mutex-unlock! mtx1)
-                                 )) ;; thread is launched
-                             (let ((run-time (- (current-seconds) start-time))) ;; couldn't launch yet
-                               (cond
-                                ((< run-time 5)) ;; blast on through
-                                ((< run-time 30)(thread-sleep! 0.1))
-                                ((< run-time 60)(thread-sleep! 2))
-                                ((< run-time 120)(thread-sleep! 3))
-                                (else (thread-sleep! 3)))
-                               (loop start-time)))))))))
-    (map thread-join! (hash-table-values threads))
-    (client-send-receive req "quit")
-    (nn-close req)
-    (exit)))
-
-;; recieve and store the file data, note: this is effectively a *server*, not a client.
-;;
-(define (compare-directories path1 path2)
-  (let ((p1dat       (make-hash-table))
-        (p2dat       (make-hash-table))
-        (numdone     0) ;; increment when recieved a quit. exit when > 2
-        (rep         (nn-socket 'rep))
-        (p1len       (string-length path1))
-        (p2len       (string-length path2))
-        (both-seen   (make-hash-table)))
-    (nn-bind    rep  
-                ;; "tcp://*:5559")
-                "ipc:///tmp/test-ipc")
-    ;; start clients
-    (thread-sleep! 0.1)
-    (system (conc "./remotediff-nmsg " path1 " &"))
-    (system (conc "./remotediff-nmsg " path2 " &"))
-    (let loop ((msg-in (nn-recv rep))
-               (last-print 0))
-      (if (equal? msg-in "quit")
-          (set! numdone (+ numdone 1)))
-      (if (and (not (equal? msg-in "quit"))
-               (< numdone 2))
-          (let* ((parts (string-split msg-in))
-                 (filen (car parts))
-                 (finfo (cadr parts))
-                 (isp1  (substring-index path1 filen 0)) ;; is this a path1?
-                 (isp2  (substring-index path2 filen 0)) ;; is this a path2?
-                 (tpth  (substring filen (if isp1 p1len p2len) (string-length filen))))
-            (hash-table-set! (if isp1 p1dat p2dat)
-                             tpth
-                             finfo)
-            (if (and (hash-table-exists? p1dat tpth)
-                     (hash-table-exists? p2dat tpth))
-                (begin
-                  (if (not (equal? (hash-table-ref p1dat tpth)
-                                   (hash-table-ref p2dat tpth)))
-                      (print "DIFF: " tpth))
-                  (hash-table-set! both-seen tpth finfo)))
-            (nn-send rep "done")
-            (loop (nn-recv rep)
-                  (if (> (- (current-seconds) last-print) 15)
-                      (begin
-                        (print "Processed " (hash-table-size p1dat) ", " (hash-table-size p2dat))
-                        (current-seconds))
-                      last-print)))))
-    (print "p1: " (hash-table-size p1dat) " p2: " (hash-table-size p2dat))
-    (hash-table-for-each
-     p1dat
-     (lambda (k v)
-       (if (not (hash-table-exists? p2dat k))
-           (print "REMOVED: " k))))
-    (hash-table-for-each
-     p2dat
-     (lambda (k v)
-       (if (not (hash-table-exists? p1dat k))
-           (print "ADDED: " k))))
-    (list p1dat p2dat)))
-
-(if (< (length (argv)) 2)
-    (begin
-      (print "Usage: remotediff-nmsg file1 file2")
-      (exit)))
-
-(if (eq? (length (argv)) 2) ;; given a single path
-    (gather-dir-info (cadr (argv)))
-    (compare-directories (cadr (argv))(caddr (argv))))
-
-(print "Done")

Index: rmt.scm
==================================================================
--- rmt.scm
+++ rmt.scm
@@ -1,23 +1,30 @@
 ;;======================================================================
 ;; Copyright 2006-2017, 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 typed-records) ;; RADT => purpose of json format??
 
 (declare (unit rmt))
 (declare (uses api))
-(declare (uses tdb))
 (declare (uses http-transport))
-;;(declare (uses nmsg-transport))
 (include "common_records.scm")
 
 ;;
 ;; THESE ARE ALL CALLED ON THE CLIENT SIDE!!!
 ;;
@@ -48,13 +55,19 @@
 
 ;; RA => e.g. usage (rmt:send-receive 'get-var #f (list varname))
 ;;
 (define (rmt:send-receive cmd rid params #!key (attemptnum 1)(area-dat #f)) ;; start attemptnum at 1 so the modulo below works as expected
 
+  ;;DOT digraph megatest_state_status {
+  ;;DOT   ranksep=0;
+  ;;DOT   // rankdir=LR;
+  ;;DOT   node [shape="box"];
+  ;;DOT "rmt:send-receive" -> MUTEXLOCK;
+  ;;DOT { edge [style=invis];"case 1" -> "case 2" -> "case 3" -> "case 4" -> "case 5" -> "case 6" -> "case 7" -> "case 8" -> "case 9" -> "case 10" -> "case 11"; }
   ;; do all the prep locked under the rmt-mutex
   (mutex-lock! *rmt-mutex*)
-
+  
   ;; 1. check if server is started IFF cmd is a write OR if we are not on the homehost, store in runremote
   ;; 2. check the age of the connections. refresh the connection if it is older than timeout-20 seconds.
   ;; 3. do the query, if on homehost use local access
   ;;
   (let* ((start-time    (current-seconds)) ;; snapshot time so all use cases get same value
@@ -71,119 +84,167 @@
 				    (remote-ro-mode-set! runremote ro-mode)
 				    (remote-ro-mode-checked-set! runremote #t)
 				    ro-mode)
 				  ro-mode)))))
 
-     ;; ensure we have a record for our connection for given area
-     (if (not runremote)                   ;; can remove this one. should never get here.         
-	 (begin
-	   (set! *runremote* (make-remote))
-	   (set! runremote   *runremote*))) ;; new runremote will come from this on next iteration
-     ;; ensure we have a homehost record
-     (if (not (pair? (remote-hh-dat runremote)))  ;; not on homehost
-	 (thread-sleep! 0.1) ;; since we shouldn't get here, delay a little
-	 (remote-hh-dat-set! runremote (common:get-homehost)))
-
-     ;;(print "BB> readonly-mode is "readonly-mode" dbfile is "dbfile)
+    ;; DOT INIT_RUNREMOTE; // leaving off - doesn't really add to the clarity
+    ;; DOT MUTEXLOCK -> INIT_RUNREMOTE [label="no remote?"];
+    ;; DOT INIT_RUNREMOTE -> MUTEXLOCK;
+    ;; ensure we have a record for our connection for given area
+    (if (not runremote)                   ;; can remove this one. should never get here.         
+	(begin
+	  (set! *runremote* (make-remote))
+	  (set! runremote   *runremote*))) ;; new runremote will come from this on next iteration
+    
+    ;; DOT SET_HOMEHOST; // leaving off - doesn't really add to the clarity
+    ;; DOT MUTEXLOCK -> SET_HOMEHOST [label="no homehost?"];
+    ;; DOT SET_HOMEHOST -> MUTEXLOCK;
+    ;; ensure we have a homehost record
+    (if (not (pair? (remote-hh-dat runremote)))  ;; not on homehost
+	(thread-sleep! 0.1) ;; since we shouldn't get here, delay a little
+	(remote-hh-dat-set! runremote (common:get-homehost)))
+    
+    ;;(print "BB> readonly-mode is "readonly-mode" dbfile is "dbfile)
     (cond
+     ;;DOT EXIT;
+     ;;DOT MUTEXLOCK -> EXIT [label="> 15 attempts"]; {rank=same "case 1" "EXIT" }
      ;; give up if more than 15 attempts
      ((> attemptnum 15)
       (debug:print 0 *default-log-port* "ERROR: 15 tries to start/connect to server. Giving up.")
       (exit 1))
 
-     ;; readonly mode, read request-  handle it - case 20
+     ;;DOT CASE2 [label="local\nreadonly\nquery"];
+     ;;DOT MUTEXLOCK -> CASE2; {rank=same "case 2" CASE2}
+     ;;DOT CASE2 -> "rmt:open-qry-close-locally";
+     ;; readonly mode, read request-  handle it - case 2
      ((and readonly-mode
            (member cmd api:read-only-queries)) 
       (mutex-unlock! *rmt-mutex*)
-      (debug:print-info 12 *default-log-port* "rmt:send-receive, case 20")
+      (debug:print-info 12 *default-log-port* "rmt:send-receive, case 2")
       (rmt:open-qry-close-locally cmd 0 params)
       )
 
+     ;;DOT CASE3 [label="write in\nread-only mode"];
+     ;;DOT MUTEXLOCK -> CASE3 [label="readonly\nmode?"]; {rank=same "case 3" CASE3}
+     ;;DOT CASE3 -> "#f";
      ;; readonly mode, write request.  Do nothing, return #f
      (readonly-mode
       (mutex-unlock! *rmt-mutex*)
-      (debug:print-info 12 *default-log-port* "rmt:send-receive, case 21")
+      (debug:print-info 12 *default-log-port* "rmt:send-receive, case 3")
       (debug:print 0 *default-log-port* "WARNING: write transaction requested on a readonly area.  cmd="cmd" params="params)
-      #f
-      )
+      #f)
 
+     ;; This block was for pre-emptively resetting the connection if there had been no communication for some time.
+     ;; I don't think it adds any value. If the server is not there, just fail and start a new connection.
+     ;; also, the expire-time calculation might not be correct. We want, time-since-last-server-access > (server:get-timeout)
+     ;;
+     ;;DOT CASE4 [label="reset\nconnection"];
+     ;;DOT MUTEXLOCK -> CASE4 [label="have connection,\nlast_access > expire_time"]; {rank=same "case 4" CASE4}
+     ;;DOT CASE4 -> "rmt:send-receive";
      ;; reset the connection if it has been unused too long
      ((and runremote
            (remote-conndat runremote)
-	   (let ((expire-time (+ (- start-time (remote-server-timeout runremote))(random 10)))) ;; Subtract or add the random value? Seems like it should be substract but Neither fixes the "WARNING: failure in with-input-from-request to #.\n message: Server closed connection before sending response"
-	     (< (http-transport:server-dat-get-last-access (remote-conndat runremote)) expire-time)))
+	   (> (current-seconds) ;; if it has been more than server-timeout seconds since last contact, close this connection and start a new on
+	      (+ (http-transport:server-dat-get-last-access (remote-conndat runremote))
+		 (remote-server-timeout runremote))))
       (debug:print-info 0 *default-log-port* "Connection to " (remote-server-url runremote) " expired due to no accesses, forcing new connection.")
+      (http-transport:close-connections area-dat: runremote)
       (remote-conndat-set! runremote #f) ;; invalidate the connection, thus forcing a new connection.
       (mutex-unlock! *rmt-mutex*)
       (rmt:send-receive cmd rid params attemptnum: attemptnum))
+     
+     ;;DOT CASE5 [label="local\nread"];
+     ;;DOT MUTEXLOCK -> CASE5 [label="server not required,\non homehost,\nread-only query"]; {rank=same "case 5" CASE5};
+     ;;DOT CASE5 -> "rmt:open-qry-close-locally";
+
      ;; on homehost and this is a read
-     ((and (not (remote-force-server runremote))      ;; honor forced use of server
-	   (cdr (remote-hh-dat runremote))     ;; on homehost
-           (member cmd api:read-only-queries)) ;; this is a read
+     ((and (not (remote-force-server runremote)) ;; honor forced use of server, i.e. server NOT required
+	   (cdr (remote-hh-dat runremote))       ;; on homehost
+           (member cmd api:read-only-queries))   ;; this is a read
       (mutex-unlock! *rmt-mutex*)
-      (debug:print-info 12 *default-log-port* "rmt:send-receive, case  3")
+      (debug:print-info 12 *default-log-port* "rmt:send-receive, case  5")
       (rmt:open-qry-close-locally cmd 0 params))
 
+     ;;DOT CASE6 [label="init\nremote"];
+     ;;DOT MUTEXLOCK -> CASE6 [label="on homehost,\nwrite query,\nhave server,\ncan't reach it"]; {rank=same "case 6" CASE6};
+     ;;DOT CASE6 -> "rmt:send-receive";
      ;; on homehost and this is a write, we already have a server, but server has died
      ((and (cdr (remote-hh-dat runremote))           ;; on homehost
            (not (member cmd api:read-only-queries))  ;; this is a write
            (remote-server-url runremote)             ;; have a server
            (not (server:ping (remote-server-url runremote))))  ;; server has died. NOTE: this is not a cheap call! Need better approach.
       (set! *runremote* (make-remote))
+      (remote-force-server-set! runremote (common:force-server?))
       (mutex-unlock! *rmt-mutex*)
-      (debug:print-info 12 *default-log-port* "rmt:send-receive, case  4.1")
+      (debug:print-info 12 *default-log-port* "rmt:send-receive, case  6")
       (rmt:send-receive cmd rid params attemptnum: attemptnum))
 
+     ;;DOT CASE7 [label="homehost\nwrite"];
+     ;;DOT MUTEXLOCK -> CASE7 [label="server not required,\non homehost,\na write,\nhave a server"]; {rank=same "case 7" CASE7};
+     ;;DOT CASE7 -> "rmt:open-qry-close-locally";
      ;; on homehost and this is a write, we already have a server
-     ((and (not (remote-force-server runremote))     ;; honor forced use of server
+     ((and (not (remote-force-server runremote))     ;; honor forced use of server, i.e. server NOT required
 	   (cdr (remote-hh-dat runremote))           ;; on homehost
            (not (member cmd api:read-only-queries))  ;; this is a write
            (remote-server-url runremote))            ;; have a server
       (mutex-unlock! *rmt-mutex*)
-      (debug:print-info 12 *default-log-port* "rmt:send-receive, case  4")
+      (debug:print-info 12 *default-log-port* "rmt:send-receive, case  4.1")
       (rmt:open-qry-close-locally cmd 0 params))
 
+     ;;DOT CASE8 [label="force\nserver"];
+     ;;DOT MUTEXLOCK -> CASE8 [label="server not required,\nhave homehost info,\nno connection yet,\nnot a read-only query"]; {rank=same "case 8" CASE8};
+     ;;DOT CASE8 -> "rmt:open-qry-close-locally";
      ;;  on homehost, no server contact made and this is a write, passively start a server 
-     ((and (not (remote-force-server runremote)) ;; honor forced use of server
-	   (cdr (remote-hh-dat runremote))       ;; new
-           (not (remote-server-url runremote))
-	   (not (member cmd api:read-only-queries)))
-      (debug:print-info 12 *default-log-port* "rmt:send-receive, case  5")
+     ((and (not (remote-force-server runremote))     ;; honor forced use of server, i.e. server NOT required
+	   (cdr (remote-hh-dat runremote))           ;; have homehost
+           (not (remote-server-url runremote))       ;; no connection yet
+	   (not (member cmd api:read-only-queries))) ;; not a read-only query
+      (debug:print-info 12 *default-log-port* "rmt:send-receive, case  8")
       (let ((server-url  (server:check-if-running *toppath*))) ;; (server:read-dotserver->url *toppath*))) ;; (server:check-if-running *toppath*))) ;; Do NOT want to run server:check-if-running - very expensive to do for every write call
 	(if server-url
 	    (remote-server-url-set! runremote server-url) ;; the string can be consumed by the client setup if needed
 	    (if (common:force-server?)
 		(server:start-and-wait *toppath*)
 		(server:kind-run *toppath*))))
       (remote-force-server-set! runremote (common:force-server?))
       (mutex-unlock! *rmt-mutex*)
-      (debug:print-info 12 *default-log-port* "rmt:send-receive, case  5.1")
+      (debug:print-info 12 *default-log-port* "rmt:send-receive, case  8.1")
       (rmt:open-qry-close-locally cmd 0 params))
 
+     ;;DOT CASE9 [label="force server\nnot on homehost"];
+     ;;DOT MUTEXLOCK -> CASE9 [label="no connection\nand either require server\nor not on homehost"]; {rank=same "case 9" CASE9};
+     ;;DOT CASE9 -> "start\nserver" -> "rmt:send-receive";
      ((or (and (remote-force-server runremote)              ;; we are forcing a server and don't yet have a connection to one
 	       (not (remote-conndat runremote)))
 	  (and (not (cdr (remote-hh-dat runremote)))        ;; not on a homehost 
 	       (not (remote-conndat runremote))))           ;; and no connection
-      (debug:print-info 12 *default-log-port* "rmt:send-receive, case  6  hh-dat: " (remote-hh-dat runremote) " conndat: " (remote-conndat runremote))
+      (debug:print-info 12 *default-log-port* "rmt:send-receive, case 9, hh-dat: " (remote-hh-dat runremote) " conndat: " (remote-conndat runremote))
       (mutex-unlock! *rmt-mutex*)
       (if (not (server:check-if-running *toppath*)) ;; who knows, maybe one has started up?
 	  (server:start-and-wait *toppath*))
-      (remote-force-server-set! runremote (common:force-server?))
       (remote-conndat-set! runremote (rmt:get-connection-info *toppath*)) ;; calls client:setup which calls client:setup-http
       (rmt:send-receive cmd rid params attemptnum: attemptnum)) ;; TODO: add back-off timeout as
+
+     ;;DOT CASE10 [label="on homehost"];
+     ;;DOT MUTEXLOCK -> CASE10 [label="server not required,\non homehost"]; {rank=same "case 10" CASE10};
+     ;;DOT CASE10 -> "rmt:open-qry-close-locally";
      ;; all set up if get this far, dispatch the query
      ((and (not (remote-force-server runremote))
 	   (cdr (remote-hh-dat runremote))) ;; we are on homehost
       (mutex-unlock! *rmt-mutex*)
-      (debug:print-info 12 *default-log-port* "rmt:send-receive, case  7")
+      (debug:print-info 12 *default-log-port* "rmt:send-receive, case 10")
       (rmt:open-qry-close-locally cmd (if rid rid 0) params))
 
+     ;;DOT CASE11 [label="send_receive"];
+     ;;DOT MUTEXLOCK -> CASE11 [label="else"]; {rank=same "case 11" CASE11};
+     ;;DOT CASE11 -> "rmt:send-receive" [label="call failed"];
+     ;;DOT CASE11 -> "RESULT" [label="call succeeded"];
      ;; not on homehost, do server query
      (else
-      (mutex-unlock! *rmt-mutex*)
+      ;; (mutex-unlock! *rmt-mutex*)
       (debug:print-info 12 *default-log-port* "rmt:send-receive, case  9")
-      (mutex-lock! *rmt-mutex*)
+      ;; (mutex-lock! *rmt-mutex*)
       (let* ((conninfo (remote-conndat runremote))
 	     (dat      (case (remote-transport runremote)
 			 ((http) (condition-case ;; handling here has caused a lot of problems. However it is needed to deal with attemtped communication to servers that have gone away
                                   (http-transport:client-api-send-receive 0 conninfo cmd params)
                                   ((commfail)(vector #f "communications fail"))
@@ -191,35 +252,49 @@
 			 (else
 			  (debug:print 0 *default-log-port* "ERROR: transport " (remote-transport runremote) " not supported")
 			  (exit))))
 	     (success  (if (vector? dat) (vector-ref dat 0) #f))
 	     (res      (if (vector? dat) (vector-ref dat 1) #f)))
-	(if (vector? conninfo)(http-transport:server-dat-update-last-access conninfo)) ;; refresh access time
+	(if (and (vector? conninfo) (< 5 (vector-length conninfo)))
+            (http-transport:server-dat-update-last-access conninfo) ;; refresh access time
+	    (begin
+              (debug:print 0 *default-log-port* "INFO: Should not get here! conninfo=" conninfo)
+              (set! conninfo #f)
+              (remote-conndat-set! *runremote* #f)
+              (http-transport:close-connections  area-dat: runremote)))
 	;; (mutex-unlock! *rmt-mutex*)
         (debug:print-info 13 *default-log-port* "rmt:send-receive, case  9. conninfo=" conninfo " dat=" dat " runremote = " runremote)
 	(mutex-unlock! *rmt-mutex*)
 	(if success ;; success only tells us that the transport was successful, have to examine the data to see if there was a detected issue at the other end
 	    (if (and (vector? res)
 		     (eq? (vector-length res) 2)
 		     (eq? (vector-ref res 1) 'overloaded)) ;; since we are looking at the data to carry the error we'll use a fairly obtuse combo to minimise the chances of some sort of collision.
+                ;; this is the case where the returned data is bad or the server is overloaded and we want
+                ;; to ease off the queries
 		(let ((wait-delay (+ attemptnum (* attemptnum 10))))
 		  (debug:print 0 *default-log-port* "WARNING: server is overloaded. Delaying " wait-delay " seconds and trying call again.")
 		  (mutex-lock! *rmt-mutex*)
+		  (http-transport:close-connections area-dat: runremote)
 		  (set! *runremote* #f) ;; force starting over
 		  (mutex-unlock! *rmt-mutex*)
 		  (thread-sleep! wait-delay)
 		  (rmt:send-receive cmd rid params attemptnum: (+ attemptnum 1)))
 		res) ;; All good, return res
 	    (begin
 	      (debug:print 0 *default-log-port* "WARNING: communication failed. Trying again, try num: " attemptnum)
-	      (remote-conndat-set!    runremote #f)
+	      (mutex-lock! *rmt-mutex*)
+              (remote-conndat-set!    runremote #f)
+	      (http-transport:close-connections area-dat: runremote)
 	      (remote-server-url-set! runremote #f)
-	      (debug:print-info 12 *default-log-port* "rmt:send-receive, case  9.1")
-	      (if (not (server:check-if-running *toppath*))
-		  (server:start-and-wait *toppath*))
+	      (mutex-unlock! *rmt-mutex*)
+              (debug:print-info 12 *default-log-port* "rmt:send-receive, case  9.1")
+	      ;; (if (not (server:check-if-running *toppath*))
+	      ;; 	  (server:start-and-wait *toppath*))
 	      (rmt:send-receive cmd rid params attemptnum: (+ attemptnum 1)))))))))
 
+    ;;DOT }
+    
 ;; (define (rmt:update-db-stats run-id rawcmd params duration)
 ;;   (mutex-lock! *db-stats-mutex*)
 ;;   (handle-exceptions
 ;;    exn
 ;;    (begin
@@ -275,11 +350,11 @@
     res))
 
 (define (rmt:open-qry-close-locally cmd run-id params #!key (remretries 5))
   (let* ((qry-is-write   (not (member cmd api:read-only-queries)))
 	 (db-file-path   (db:dbfile-path)) ;;  0))
-	 (dbstruct-local (db:setup))  ;; make-dbr:dbstruct path:  dbdir local: #t)))
+	 (dbstruct-local (db:setup #t))  ;; make-dbr:dbstruct path:  dbdir local: #t)))
 	 (read-only      (not (file-write-access? db-file-path)))
 	 (start          (current-milliseconds))
 	 (resdat         (if (not (and read-only qry-is-write))
 			     (let ((v (api:execute-requests dbstruct-local (vector (symbol->string cmd) params))))
 			       (handle-exceptions ;; there has been a long history of receiving strange errors from values returned by the client when things go wrong..
@@ -434,10 +509,14 @@
 (define (rmt:get-targets)
   (rmt:send-receive 'get-targets #f '()))
 
 (define (rmt:get-target run-id)
   (rmt:send-receive 'get-target run-id (list run-id)))
+
+(define (rmt:get-run-times runpatt targetpatt)
+  (rmt:send-receive 'get-run-times #f (list runpatt targetpatt ))) 
+
 
 ;;======================================================================
 ;;  T E S T S
 ;;======================================================================
 
@@ -474,21 +553,24 @@
 
 (define (rmt:set-tests-state-status run-id                      testnames currstate currstatus newstate newstatus)
   (rmt:send-receive 'set-tests-state-status run-id (list run-id testnames currstate currstatus newstate newstatus)))
 
 (define (rmt:get-tests-for-run run-id testpatt states statuses offset limit not-in sort-by sort-order qryvals last-update mode)
-  (if (number? run-id)
-      (rmt:send-receive 'get-tests-for-run run-id (list run-id testpatt states statuses offset limit not-in sort-by sort-order qryvals last-update mode))
-      (begin
-	(debug:print-error 0 *default-log-port* "rmt:get-tests-for-run called with bad run-id=" run-id)
-	(print-call-chain (current-error-port))
-	'())))
+  ;; (if (number? run-id)
+  (rmt:send-receive 'get-tests-for-run run-id (list run-id testpatt states statuses offset limit not-in sort-by sort-order qryvals last-update mode)))
+  ;;    (begin
+  ;;	(debug:print-error 0 *default-log-port* "rmt:get-tests-for-run called with bad run-id=" run-id)
+  ;;	(print-call-chain (current-error-port))
+  ;;	'())))
 
 ;; get stuff via synchash 
 (define (rmt:synchash-get run-id proc synckey keynum params)
   (rmt:send-receive 'synchash-get run-id (list run-id proc synckey keynum params)))
 
+(define (rmt:get-tests-for-run-mindata run-id testpatt states status not-in)
+  (rmt:send-receive 'get-tests-for-run-mindata run-id (list run-id testpatt states status not-in)))
+  
 ;; IDEA: Threadify these - they spend a lot of time waiting ...
 ;;
 (define (rmt:get-tests-for-runs-mindata run-ids testpatt states status not-in)
   (let ((multi-run-mutex (make-mutex))
 	(run-id-list (if run-ids
@@ -612,10 +694,13 @@
   (rmt:send-receive 'top-test-set-per-pf-counts run-id (list run-id test-name)))
 
 (define (rmt:get-raw-run-stats run-id)
   (rmt:send-receive 'get-raw-run-stats run-id (list run-id)))
 
+(define (rmt:get-test-times runname target)
+  (rmt:send-receive 'get-test-times #f (list runname target ))) 
+
 ;;======================================================================
 ;;  R U N S
 ;;======================================================================
 
 (define (rmt:get-run-info run-id)
@@ -622,10 +707,13 @@
   (rmt:send-receive 'get-run-info run-id (list run-id)))
 
 (define (rmt:get-num-runs runpatt)
   (rmt:send-receive 'get-num-runs #f (list runpatt)))
 
+(define (rmt:get-runs-cnt-by-patt runpatt targetpatt keys)
+  (rmt:send-receive 'get-runs-cnt-by-patt #f (list runpatt  targetpatt keys)))
+
 ;; Use the special run-id == #f scenario here since there is no run yet
 (define (rmt:register-run keyvals runname state status user contour)
   (rmt:send-receive 'register-run #f (list keyvals runname state status user contour)))
     
 (define (rmt:get-run-name-from-id run-id)
@@ -641,10 +729,13 @@
   (rmt:send-receive 'delete-old-deleted-test-records #f '()))
 
 (define (rmt:get-runs runpatt count offset keypatts)
   (rmt:send-receive 'get-runs #f (list runpatt count offset keypatts)))
 
+(define (rmt:simple-get-runs runpatt count offset target)
+  (rmt:send-receive 'simple-get-runs #f (list runpatt count offset target)))
+
 (define (rmt:get-all-run-ids)
   (rmt:send-receive 'get-all-run-ids #f '()))
 
 (define (rmt:get-prev-run-ids run-id)
   (rmt:send-receive 'get-prev-run-ids #f (list run-id)))
@@ -749,20 +840,24 @@
     (rmt:send-receive 'teststep-set-status! run-id (list run-id test-id teststep-name state-in status-in comment logfile))))
 
 (define (rmt:get-steps-for-test run-id test-id)
   (rmt:send-receive 'get-steps-for-test run-id (list run-id test-id)))
 
+(define (rmt:get-steps-info-by-id test-step-id)
+  (rmt:send-receive 'get-steps-info-by-id #f (list test-step-id)))
+
 ;;======================================================================
 ;;  T E S T   D A T A 
 ;;======================================================================
 
 (define (rmt:read-test-data run-id test-id categorypatt #!key (work-area #f)) 
   (rmt:send-receive 'read-test-data run-id (list run-id test-id categorypatt)))
-;;   (let ((tdb  (rmt:open-test-db-by-test-id run-id test-id work-area: work-area)))
-;;     (if tdb
-;; 	(tdb:read-test-data tdb test-id categorypatt)
-;; 	'())))
+(define (rmt:read-test-data* run-id test-id categorypatt varpatt #!key (work-area #f)) 
+  (rmt:send-receive 'read-test-data* run-id (list run-id test-id categorypatt varpatt)))
+
+(define (rmt:get-data-info-by-id test-data-id)
+   (rmt:send-receive 'get-data-info-by-id #f (list test-data-id)))
 
 (define (rmt:testmeta-add-record testname)
   (rmt:send-receive 'testmeta-add-record #f (list testname)))
 
 (define (rmt:testmeta-get-record testname)
@@ -790,10 +885,26 @@
 (define (rmt:tasks-set-state-given-param-key param-key new-state)
   (rmt:send-receive 'tasks-set-state-given-param-key #f (list  param-key new-state)))
 
 (define (rmt:tasks-get-last target runname)
   (rmt:send-receive 'tasks-get-last #f (list target runname)))
+
+;;======================================================================
+;; N O   S Y N C   D B 
+;;======================================================================
+
+(define (rmt:no-sync-set var val)
+  (rmt:send-receive 'no-sync-set #f `(,var ,val)))
+
+(define (rmt:no-sync-get/default var default)
+  (rmt:send-receive 'no-sync-get/default #f `(,var ,default)))
+
+(define (rmt:no-sync-del! var)
+  (rmt:send-receive 'no-sync-del! #f `(,var)))
+
+(define (rmt:no-sync-get-lock keyname)
+  (rmt:send-receive 'no-sync-get-lock #f `(,keyname)))
 
 ;;======================================================================
 ;; A R C H I V E S
 ;;======================================================================
 

Index: rpc-transport.scm
==================================================================
--- rpc-transport.scm
+++ rpc-transport.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 .
+;;
 
 (require-extension (srfi 18) extras tcp s11n rpc)
 (import (prefix rpc rpc:))
 
 (use sqlite3 srfi-1 posix regex regex-case srfi-69 hostinfo md5 message-digest)

DELETED rpctest/rpctest-continuous-client.scm
Index: rpctest/rpctest-continuous-client.scm
==================================================================
--- rpctest/rpctest-continuous-client.scm
+++ /dev/null
@@ -1,138 +0,0 @@
-;;;; rpc-demo.scm
-;;;; Simple database server / client
-
-;;; start server thusly: ./rpctest server test.db
-;;; you will need to init test.db:
-;;; sqlite3 test.db "CREATE TABLE foo (id INTEGER PRIMARY KEY, var TEXT, val TEXT);"
-
-(require-extension (srfi 18) extras tcp rpc sql-de-lite)
-
-;;; Common things
-
-(define total-queries 0)
-(define start-time (current-seconds))
-
-(define operation (string->symbol (car (command-line-arguments))))
-(define param (cadr (command-line-arguments)))
-(print "Operation: " operation ", param: " param)
-
-;; have a pool of db's to pick from
-(define *dbpool* '())
-(define *pool-mutex* (make-mutex))
-1
-(define (get-db)
-  (mutex-lock! *pool-mutex*)
-  (if (null? *dbpool*)
-      (begin
-	(mutex-unlock! *pool-mutex*)
-	(let ((db (open-database param)))
-	  (set-busy-handler! db (busy-timeout 10000))
-	  (exec (sql db "PRAGMA synchronous=0;"))
-	  db))
-      (let ((res (car *dbpool*)))
-	(set! *dbpool* (cdr *dbpool*))
-	(mutex-unlock! *pool-mutex*)
-	res)))
-
-(define (return-db db)
-  (mutex-lock! *pool-mutex*)
-  (set! *dbpool* (cons db *dbpool* ))
-  (let ((res (length *dbpool*)))
-    (mutex-unlock! *pool-mutex*)
-    res))
-
-(define rpc:listener
-  (if (eq? operation 'server)
-      (tcp-listen (rpc:default-server-port))
-      (tcp-listen 0)))
-
-;; Start server thread
-(define rpc:server
-  (make-thread
-   (cute (rpc:make-server rpc:listener) "rpc:server") ;; NOTE: see equivalent code below
-   'rpc:server))
-
-;; This is what the code would look like without cute
-;; (define rpc:server
-;;   (make-thread
-;;    (lambda ()
-;;      ((rpc:make-server rpc:listener) "rpc:server"))
-;;    'rpc:server))
-
-(thread-start! rpc:server)
-
-;;; Server side
-
-(define (server)
-  (rpc:publish-procedure!
-   'change-response-port
-   (lambda (port)
-     (rpc:default-server-port port))
-   #f)
-  ;;(let ((db  (get-db))(open-database param)))
-  ;; (set-finalizer! db finalize!)
-  (rpc:publish-procedure!
-   'query
-   (lambda (sqlstmt callback)
-     (set! total-queries (+ total-queries 1))
-     (print "Executing query '" sqlstmt "' ...")
-     (let ((db (get-db)))
-       (query (for-each-row
-	       callback)
-	      (sql db sqlstmt))
-       (print "Query rate: " (/ total-queries (/ (- (current-seconds) start-time) 60)) " per minute")
-       (print "num dbs: " (return-db db))
-       )))
-  (thread-join! rpc:server))
-
-;;; Client side
-
-(define (callback1 . columns)
-  (let loop ((c columns) (i 0))
-    (unless (null? c)
-      (printf "~a=~s " i (car c))
-      (loop (cdr c) (+ i 1))))
-  (newline))
-
-(define callback2-results '())
-
-(define (callback2 . columns)
-  (set! callback2-results (cons columns callback2-results)))
-
-(define (client param)
-  ((rpc:procedure 'change-response-port "localhost")
-   (tcp-listener-port rpc:listener))
-  ((rpc:procedure 'query "localhost") param callback1)
-  (rpc:publish-procedure! 'callback2 callback2)
-  ((rpc:procedure 'query "localhost") param callback2)
-  (pp callback2-results)
-  (rpc:close-all-connections!)
-  ;; (rpc:close-connection! "localhost" (rpc:default-server-port))
-  )
-
-(define (run-query param)
-  ((rpc:procedure 'query "localhost") param callback1)
-  ((rpc:procedure 'query "localhost") param callback2)
-  callback2-results)
-
-(define (continuous-client #!key (duration 600)) ;; default - run for 10 minutes
-  ((rpc:procedure 'change-response-port "localhost")
-   (tcp-listener-port rpc:listener))
-  (rpc:publish-procedure! 'callback2 callback2)
-  (let loop ()
-    (if (< (- (current-seconds) start-time) duration)
-	(begin
-	  (run-query (conc "INSERT INTO foo (var,val) VALUES (" (random 1000) "," (random 1000) ");"))
-	  (let ((numrows (caaar (run-query "SELECT COUNT(id) FROM foo;"))))
-	    (if (and (number? numrows)
-		     (> numrows 300))
-		(print (run-query (conc "DELETE FROM foo WHERE var > " (random 1000) ";")))))
-	  (loop))))
-  (rpc:close-all-connections!))
-
-;;; Run it
-
-(if (eq? operation 'server)
-    (server)
-    (continuous-client))
-

DELETED rpctest/rpctest.scm
Index: rpctest/rpctest.scm
==================================================================
--- rpctest/rpctest.scm
+++ /dev/null
@@ -1,109 +0,0 @@
-;;;; rpc-demo.scm
-;;;; Simple database server / client
-
-;;; start server thusly: ./rpctest server test.db
-;;; you will need to init test.db:
-;;; sqlite3 test.db "CREATE TABLE foo (id INTEGER PRIMARY KEY, var TEXT, val TEXT);"
-
-(require-extension (srfi 18) extras tcp rpc sql-de-lite)
-
-;;; Common things
-
-(define total-queries 0)
-(define start-time (current-seconds))
-
-(define operation (string->symbol (car (command-line-arguments))))
-(define param (cadr (command-line-arguments)))
-(print "Operation: " operation ", param: " param)
-
-;; have a pool of db's to pick from
-(define *dbpool* '())
-(define *pool-mutex* (make-mutex))
-
-(define (get-db)
-  (mutex-lock! *pool-mutex*)
-  (if (null? *dbpool*)
-      (begin
-	(mutex-unlock! *pool-mutex*)
-	(let ((db (open-database param)))
-	  (set-busy-handler! db (busy-timeout 10000))
-	  (exec (sql db "PRAGMA synchronous=0;"))
-	  db))
-      (let ((res (car *dbpool*)))
-	(set! *dbpool* (cdr *dbpool*))
-	(mutex-unlock! *pool-mutex*)
-	res)))
-
-(define (return-db db)
-  (mutex-lock! *pool-mutex*)
-  (set! *dbpool* (cons db *dbpool* ))
-  (let ((res (length *dbpool*)))
-    (mutex-unlock! *pool-mutex*)
-    res))
-
-(define rpc:listener
-  (if (eq? operation 'server)
-      (tcp-listen (rpc:default-server-port))
-      (tcp-listen 0)))
-
-;; Start server thread
-(define rpc:server
-  (make-thread
-   (cute (rpc:make-server rpc:listener) "rpc:server")
-   'rpc:server))
-
-(thread-start! rpc:server)
-
-;;; Server side
-
-(define (server)
-  (rpc:publish-procedure!
-   'change-response-port
-   (lambda (port)
-     (rpc:default-server-port port))
-   #f)
-  ;;(let ((db  (get-db))(open-database param)))
-  ;; (set-finalizer! db finalize!)
-  (rpc:publish-procedure!
-   'query
-   (lambda (sqlstmt callback)
-     (set! total-queries (+ total-queries 1))
-     (print "Executing query '" sqlstmt "' ...")
-     (let ((db (get-db)))
-       (query (for-each-row
-	       callback)
-	      (sql db sqlstmt))
-       (print "Query rate: " (/ total-queries (/ (- (current-seconds) start-time) 60)) " per minute")
-       (print "num dbs: " (return-db db))
-       )))
-  (thread-join! rpc:server))
-
-;;; Client side
-
-(define (callback1 . columns)
-  (let loop ((c columns) (i 0))
-    (unless (null? c)
-      (printf "~a=~s " i (car c))
-      (loop (cdr c) (+ i 1))))
-  (newline))
-
-(define callback2-results '())
-
-(define (callback2 . columns)
-  (set! callback2-results (cons columns callback2-results)))
-
-(define (client)
-  ((rpc:procedure 'change-response-port "localhost")
-   (tcp-listener-port rpc:listener))
-  ((rpc:procedure 'query "localhost") param callback1)
-  (rpc:publish-procedure! 'callback2 callback2)
-  ((rpc:procedure 'query "localhost") param callback2)
-  (pp callback2-results)
-  (rpc:close-connection! "localhost" (rpc:default-server-port)))
-
-;;; Run it
-
-(if (eq? operation 'server)
-    (server)
-    (client))
-

DELETED rpctest/run-client.sh
Index: rpctest/run-client.sh
==================================================================
--- rpctest/run-client.sh
+++ /dev/null
@@ -1,12 +0,0 @@
-#!/bin/bash
-
-
-while ./rpctest client "insert into foo (var,val) values ($RANDOM,$RANDOM);";do
-    numrows=$(./rpctest client "select count(id) from foo;") # |wc -l)
-    deletefrom=$RANDOM
-    echo "numrows=$numrows, deletefrom=$deletefrom"
-    if [[ $numrows -gt 300 ]];then
-	echo "numrows=$numrows, deletefrom=$deletefrom"
-	./rpctest client "delete from foo where var > $deletefrom;"
-    fi
-done

Index: run_records.scm
==================================================================
--- run_records.scm
+++ run_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 .
+;;
 ;;======================================================================
 
 (define-inline (runs:runrec-make-record) (make-vector 13))
 (define-inline (runs:runrec-get-target  vec)(vector-ref vec 0))  ;; a/b/c
 (define-inline (runs:runrec-get-runname vec)(vector-ref vec 1))  ;; string

Index: runconfig.scm
==================================================================
--- runconfig.scm
+++ runconfig.scm
@@ -73,11 +73,11 @@
   (let ((runconfigf (conc  *toppath* "/runconfigs.config"))
 	(targ       (or (common:args-get-target)
 			targ-from-db
 			(get-environment-variable "MT_TARGET"))))
     (pop-directory)
-    (if (file-exists? runconfigf)
+    (if (common:file-exists? runconfigf)
 	(setup-env-defaults runconfigf run-id #t keyvals
 			    environ-patt: (conc "(default"
 						(if targ
 						    (conc "|" targ ")")
 						    ")")))

Index: runconfigs.config
==================================================================
--- runconfigs.config
+++ runconfigs.config
@@ -7,13 +7,13 @@
 #
 
 # 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=/mfs/matt/.sysmaint/local.config
-quick:scheduled:sync        cron=  0/5 * * * *;dbdest=pgdb;appendconf=/mfs/matt/.sysmaint/local.config
-fast:scheduled:sync-prepend cron=  0/1 * * * *;dbdest=pgdb;appendconf=/mfs/matt/.sysmaint/local.config
+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?
@@ -25,24 +25,25 @@
 # [v1.63/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             runtrans=auto;         glob=/home/matt/data/megatest/*.scm
-snazy:file:run             runtrans=corporate-ww; glob=/home/matt/data/megatest/*.scm
-short:file:run             runtrans=short;        glob=/home/matt/data/megatest/*.scm
+# commented out for debug
+quick:file:run             runtrans=auto;         glob=/home/matt/data/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.63;\
-                           http://www.kiatoa.com/fossils/megatest_qa=trunk;\
-		           http://www.kiatoa.com/fossils/megatest=v1.64
+# # fossil based trigger
+# #
+# quick:fossil:run           http://www.kiatoa.com/fossils/megatest=v1.63;\
+#                            http://www.kiatoa.com/fossils/megatest_qa=trunk;\
+# 		           http://www.kiatoa.com/fossils/megatest=v1.64
 
 # field          allowed values
 # -----          --------------
 # minute         0-59
 # hour           0-23

Index: runs-launch-loop-test.scm
==================================================================
--- runs-launch-loop-test.scm
+++ runs-launch-loop-test.scm
@@ -1,5 +1,20 @@
+;; 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-69)
 
 (define (runs:queue-next-hed tal reg n regful)
   (if regful
       (car reg)

Index: runs.scm
==================================================================
--- runs.scm
+++ runs.scm
@@ -8,13 +8,12 @@
 ;;  implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
 ;;  PURPOSE.
 
 ;;  strftime('%m/%d/%Y %H:%M:%S','now','localtime')
 
-(use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking (srfi 18) 
+(use (prefix sqlite3 sqlite3:) srfi-1 posix regex regex-case srfi-69 (srfi 18) 
      posix-extras directory-utils pathname-expand typed-records format)
-(import (prefix sqlite3 sqlite3:))
 
 (declare (unit runs))
 (declare (uses db))
 (declare (uses common))
 (declare (uses items))
@@ -21,11 +20,10 @@
 (declare (uses runconfig))
 (declare (uses tests))
 (declare (uses server))
 (declare (uses mt))
 (declare (uses archive))
-(declare (uses keys))
 ;; (declare (uses filedb))
 
 (include "common_records.scm")
 (include "key_records.scm")
 (include "db_records.scm")
@@ -48,10 +46,50 @@
 (defstruct runs:testdat
   hed tal reg reruns  test-record
   test-name item-path jobgroup
   waitons testmode  newtal itemmaps prereqs-not-met)
 
+
+(define (runs:get-mt-env-alist run-id runname target testname itempath)
+  ;;(bb-check-path msg: "runs:set-megatest-env-vars entry")
+  `(("MT_TEST_NAME"     . ,testname)
+    
+    ("MT_ITEMPATH"      . ,itempath)
+
+    ("MT_TARGET"        . ,target)
+    
+    ("MT_RUNNAME"       . ,runname)
+    
+    ("MT_RUN_AREA_HOME" . ,*toppath*)
+    
+    ,@(let* ((link-tree (common:get-linktree))) ;; (configf:lookup *configdat* "setup" "linktree")))
+        (if link-tree
+            (list (cons "MT_LINKTREE" link-tree)
+                  
+                  (cons "MT_TEST_RUN_DIR"
+                        (conc link-tree  "/" target "/" runname "/" testname
+                              (if (and (string? itempath) (not (equal? itempath "")))
+                                  (conc "/" itempath)
+                                  "")))
+                  )
+            '()))
+    
+    ,@(map
+       (lambda (key)
+         (cons  (car key) (cadr key)))
+       (keys:target->keyval (rmt:get-keys) target))
+    
+    ,@(map (lambda (var)
+             (let ((val (configf:lookup *configdat* "env-override" var)))
+               (cons var val)))
+           (configf:section-vars *configdat* "env-override"))))
+
+
+    
+
+    
+    
 ;; set up needed environment variables given a run-id and optionally a target, itempath etc.
 ;;
 (define (runs:set-megatest-env-vars run-id #!key (inkeys #f)(inrunname #f)(inkeyvals #f)(intarget #f)(testname #f)(itempath #f))
   ;;(bb-check-path msg: "runs:set-megatest-env-vars entry")
   (let* ((target    (or intarget 
@@ -96,18 +134,28 @@
 		(msg        ((condition-property-accessor 'exn 'message) exn)))
 	    (if (< count 5)
 		(begin ;; this call is colliding, do some crude stuff to fix it.
 		  (debug:print 0 *default-log-port* "ERROR: *configdat* was inaccessible! This should never happen. Retry #" count)
 		  (launch:setup force-reread: #t)
-		  (fatal-loop (+ count 1)))
+		  (fatal-loop (+ count 1))) 
 		(begin
 		  (debug:print 0 *default-log-port* "FATAL: *configdat* was inaccessible! This should never happen. Retried " count " times. Message: " msg)
 		  (debug:print 0 *default-log-port* "Call chain:")
 		  (with-output-to-port *default-log-port*
-		    (lambda ()(pp call-chain)))
+
+                    (lambda ()
+                      (print "*configdat* is >>"*configdat*"<<")
+                      (pp *configdat*)
+                      (pp call-chain)))
+                  
 		  (exit 1))))
           ;;(bb-check-path msg: "runs:set-megatest-env-vars block 1.5")
+          (when (or (not *configdat*) (not (hash-table? *configdat*)))
+              (debug:print 0 *default-log-port* "WARNING: *configdat* was inaccessible! This should never happen.  Brute force reread.")
+              ;;(BB> "ERROR: *configdat* was inaccessible! This should never happen.  Brute force reread.")
+              (thread-sleep! 2) ;; assuming nfs lag.
+              (launch:setup force-reread: #t))
           (alist->env-vars (hash-table-ref/default *configdat* "env-override" '())))) ;;;; environment is tainted HERE in this let block.
     ;;(bb-check-path msg: "runs:set-megatest-env-vars block 2")
     ;; Lets use this as an opportunity to put MT_RUNNAME in the environment
     (let ((runname  (if inrunname inrunname (rmt:get-run-name-from-id run-id))))
       (if runname
@@ -176,19 +224,23 @@
 	  (hash-table-set! *runs:denoise* key currtime)
 	  #t)
 	#f)))
 
 (define (runs:can-run-more-tests runsdat run-id jobgroup max-concurrent-jobs)
+
   ;; Take advantage of a good place to exit if running the one-pass methodology
   (if (and (> (runs:dat-can-run-more-tests-count runsdat) 20)
 	   (args:get-arg "-one-pass"))
       (exit 0))
-  (thread-sleep! (cond
+
+  (thread-sleep! (cond ;; BB: check with Matt.  Should this sleep move to cond clauses below where we determine we have too many jobs running rather than each time the and condition above is true (which seems like always)?
         	  ((> (runs:dat-can-run-more-tests-count runsdat) 20)
 		   (if (runs:lownoise "waiting on tasks" 60)(debug:print-info 2 *default-log-port* "waiting for tasks to complete, sleeping briefly ..."))
-		   2);; obviously haven't had any work to do for a while
+                   (configf:lookup-number *configdat* "setup" "inter-test-delay" default: 0.1) ;; was 2
+		   );; obviously haven't had any work to do for a while
         	  (else 0)))
+  
   (let* ((num-running             (rmt:get-count-tests-running run-id))
 	 (num-running-in-jobgroup (rmt:get-count-tests-running-in-jobgroup run-id jobgroup))
 	 (job-group-limit         (let ((jobg-count (config-lookup *configdat* "jobgroups" jobgroup)))
 				    (if (string? jobg-count)
 					(string->number jobg-count)
@@ -199,11 +251,11 @@
 	(begin
 	  (debug:print 2 *default-log-port* "max-concurrent-jobs: " max-concurrent-jobs ", num-running: " num-running)
 	  (set! *last-num-running-tests* num-running)))
     (if (not (eq? 0 *globalexitstatus*))
 	(list #f num-running num-running-in-jobgroup max-concurrent-jobs job-group-limit)
-	(let ((can-not-run-more (cond
+	(let* ((can-not-run-more (cond
 				 ;; if max-concurrent-jobs is set and the number running is greater 
 				 ;; than it then cannot run more jobs
 				 ((and max-concurrent-jobs (>= num-running max-concurrent-jobs))
 				  (if (runs:lownoise "mcj msg" 60)
 				      (debug:print 0 *default-log-port* "WARNING: Max running jobs exceeded, current number running: " num-running 
@@ -218,10 +270,91 @@
 						   " in jobgroup \"" jobgroup "\" exceeds limit of " job-group-limit))
 				  #t)
 				 (else #f))))
 	  (list (not can-not-run-more) num-running num-running-in-jobgroup max-concurrent-jobs job-group-limit)))))
 
+(define (runs:run-pre-hook run-id)
+    (let* ((run-pre-hook   (configf:lookup *configdat* "runs" "pre-hook"))
+           (existing-tests (if run-pre-hook
+                               (rmt:get-tests-for-run run-id "%" '() '() ;; run-id testpatt states statuses
+                                                      #f #f ;; offset limit
+                                                      #f ;; not-in
+                                                      #f ;; sort-by
+                                                      #f ;; sort-order
+                                                      #f ;; get full data (not 'shortlist)
+                                                      0 ;; (runs:gendat-inc-results-last-update *runs:general-data*) ;; last update time
+                                                      'dashboard)
+                               '()))
+           (log-dir         (conc *toppath* "/logs"))
+           (log-file        (conc "pre-hook-" (string-translate (getenv "MT_TARGET") "/" "-") "-" (getenv "MT_RUNNAME") ".log"))
+           (full-log-fname  (conc log-dir "/" log-file)))
+      (if run-pre-hook
+          (if (null? existing-tests)
+              (let* ((use-log-dir (if (not (directory-exists? log-dir))
+                                      (handle-exceptions
+                                       exn
+                                       (begin
+                                         (debug:print 0 *default-log-port* "WARNING: Failed to create " log-dir)
+                                         #f)
+                                       (create-directory log-dir #t)
+                                       #t)
+                                      #t))
+                     (start-time   (current-seconds))
+                     (actual-logf  (if use-log-dir full-log-fname log-file)))
+                (handle-exceptions
+                 exn
+                 (begin
+                   (print-call-chain *default-log-port*)
+                   (debug:print 0 *default-log-port* "Message: " ((condition-property-accessor 'exn 'message) exn))
+                   (debug:print 0 *default-log-port* "ERROR: failed to run pre-hook " run-pre-hook ", check the log " log-file))
+                 (debug:print-info 0 *default-log-port* "running run-pre-hook: \"" run-pre-hook "\", log is " actual-logf)
+                 (system (conc run-pre-hook " >> " actual-logf " 2>&1"))
+                 (debug:print-info 0 *default-log-port* "pre-hook \"" run-pre-hook "\" took " (- (current-seconds) start-time) " seconds to run.")))
+              (debug:print 0 *default-log-port* "Skipping pre-hook call \"" run-pre-hook "\" as there are existing tests for this run.")))))
+    
+(define (runs:run-post-hook run-id)
+    (let* ((run-post-hook   (configf:lookup *configdat* "runs" "post-hook"))
+           (existing-tests (if run-post-hook
+                               (rmt:get-tests-for-run run-id "%" '() '() ;; run-id testpatt states statuses
+                                                      #f #f ;; offset limit
+                                                      #f ;; not-in
+                                                      #f ;; sort-by
+                                                      #f ;; sort-order
+                                                      #f ;; get full data (not 'shortlist)
+                                                      0 ;; (runs:gendat-inc-results-last-update *runs:general-data*) ;; last update time
+                                                      'dashboard)
+                               '()))
+           (log-dir         (conc *toppath* "/logs"))
+           (log-file        (conc "post-hook-" (string-translate (getenv "MT_TARGET") "/" "-") "-" (getenv "MT_RUNNAME") ".log"))
+           (full-log-fname  (conc log-dir "/" log-file)))
+      (if run-post-hook
+          ;; (if (null? existing-tests)
+          ;;    (debug:print 0 *default-log-port* "Skipping post-hook call \"" run-post-hook "\" as there are existing tests for this run.")))))
+	  (let* ((use-log-dir (if (not (directory-exists? log-dir))
+				  (handle-exceptions
+				      exn
+				      (begin
+					(debug:print 0 *default-log-port* "WARNING: Failed to create " log-dir)
+					#f)
+				    (create-directory log-dir #t)
+				    #t)
+				  #t))
+		 (start-time   (current-seconds))
+		 (actual-logf  (if use-log-dir full-log-fname log-file)))
+	    (handle-exceptions
+		exn
+		(begin
+		  (print-call-chain *default-log-port*)
+		  (debug:print 0 *default-log-port* "Message: " ((condition-property-accessor 'exn 'message) exn))
+		  (debug:print 0 *default-log-port* "ERROR: failed to run post-hook " run-post-hook ", check the log " log-file))
+	      (debug:print-info 0 *default-log-port* "running run-post-hook: \"" run-post-hook "\", log is " actual-logf)
+	      (system (conc run-post-hook " >> " actual-logf " 2>&1"))
+	      (debug:print-info 0 *default-log-port* "post-hook \"" run-post-hook "\" took " (- (current-seconds) start-time) " seconds to run."))))))
+
+;; return #t when all items in waitors-upon list are represented in test-patt, #f otherwise.
+(define (runs:testpatts-mention-waitors-upon? test-patt waitors-upon)
+  (null? (tests:filter-test-names-not-matched waitors-upon test-patt)))
 
 ;;  test-names: Comma separated patterns same as test-patts but used in selection 
 ;;              of tests to run. The item portions are not respected.
 ;;              FIXME: error out if /patt specified
 ;;            
@@ -237,10 +370,11 @@
 	 ;; need to process runconfigs before generating these lists
 	 (all-tests-registry #f)  ;; (tests:get-all)) ;; (tests:get-valid-tests (make-hash-table) test-search-path)) ;; all valid tests to check waiton names
 	 (all-test-names     #f)  ;; (hash-table-keys all-tests-registry))
 	 (test-names         #f)  ;; Generated by a call to (tests:filter-test-names all-test-names test-patts))
 	 (required-tests     #f)  ;; Put fully qualified test/testpath names in this list to be done
+         (waitors-upon       (make-hash-table)) ;; given a test, return list of tests waiting upon this test.
 	 (task-key           (conc (hash-table->alist flags) " " (get-host-name) " " (current-process-id)))
 	 ;; (tdbdat             (tasks:open-db))
 	 (config-reruns      (let ((x (configf:lookup *configdat* "setup" "reruns")))
 			       (if x (string->number x) #f)))
 	 (allowed-tests      #f))
@@ -279,23 +413,29 @@
 		       (thread-start! th1)
 		       (thread-join! th2)))))
       (set-signal-handler! signal/int sighand)
       (set-signal-handler! signal/term sighand))
 
-    ;; force the starting of a server
-    (debug:print 0 *default-log-port* "waiting on server...")
-    (server:start-and-wait *toppath*)
+    ;; force the starting of a server -- removed BB 17ww28 - no longer needed.
+    ;;(debug:print 0 *default-log-port* "waiting on server...")
+    ;;(server:start-and-wait *toppath*)
     
     (runs:set-megatest-env-vars run-id inkeys: keys inrunname: runname) ;; these may be needed by the launching process
-    (set! runconf (if (file-exists? runconfigf)
+    (set! runconf (if (common:file-exists? runconfigf)
 		      (setup-env-defaults runconfigf run-id *already-seen-runconfig-info* keyvals target)
 		      (begin
 			(debug:print 0 *default-log-port* "WARNING: You do not have a run config file: " runconfigf)
 			#f)))
 
     (if (not test-patts) ;; first time in - adjust testpatt
 	(set! test-patts (common:args-get-testpatt runconf)))
+    ;; if test-patts is #f at this point there is something wrong and we need to bail out
+    (if (not test-patts)
+	(begin
+	  (debug:print 0 *default-log-port* "WARNING: there is no test pattern for this run. Exiting now.")
+	  (exit 0)))
+    
     (if (args:get-arg "-tagexpr")
 	(begin
 	  (set! allowed-tests (string-join (runs:get-tests-matching-tags (args:get-arg "-tagexpr")) ","))
 	  	  (debug:print-info 0 *default-log-port* "filtering initial test list with tagexpr: " (args:get-arg "-tagexpr") " => " allowed-tests)
 		  ));; tests will be ANDed with this list
@@ -320,12 +460,13 @@
     ;; 1. fill required tests with test-patts
     ;; 2. scan testconfigs and if waitons, itemwait, itempatt calc prior test test-patt
     ;; 3. repeat until all deps propagated
     
     ;; any tests with direct mention in test-patts can be added to required
+    ;;(set! required-tests     (lset-intersection equal? (string-split test-patts ",") all-test-names))
+    (set! required-tests     (tests:filter-test-names all-test-names test-patts))
     ;;
-    (set! required-tests     (lset-intersection equal? (string-split test-patts ",") all-test-names))
     ;; (set! required-tests     (lset-intersection equal? test-names all-test-names))
     
     ;; look up all tests matching the comma separated list of globs in
     ;; test-patts (using % as wildcard)
 
@@ -361,24 +502,35 @@
 	   (string-split (or (configf:lookup *configdat* "setup" "allow-auto-rerun") "")))))
 
     ;; Ensure all tests are registered in the test_meta table
     (runs:update-all-test_meta #f)
 
+    ;; run the run prehook if there are no tests yet run for this run:
+    ;;
+    (runs:run-pre-hook run-id)
+    
     ;; now add non-directly referenced dependencies (i.e. waiton)
     ;;======================================================================
     ;; refactoring this block into tests:get-full-data
     ;;
     ;; What happended, this code is now duplicated in tests!?
     ;;
     ;;======================================================================
     
-    (if (not (null? test-names))
+    (if (not (null? test-names)) ;; BEGIN test-names loop
 	(let loop ((hed (car test-names))   ;; NOTE: This is the main loop that iterates over the 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* "\n\ntestpatt elaboration loop => hed="hed " tal="tal" test-patts="test-patts" test-names="test-names)
 	  (change-directory *toppath*) ;; PLEASE OPTIMIZE ME!!! I think this should be a no-op but there are several places where change-directories could be happening.
 	  (setenv "MT_TEST_NAME" hed) ;; 
-	  (let*-values (((waitons waitors config)(tests:get-waitons hed all-tests-registry)))
+	  (let*-values (((waitons waitors config) (tests:get-waitons hed all-tests-registry))
+                        ((hed-mode)
+                         (let ((m (config-lookup config "requirements" "mode")))
+                           (if m (map string->symbol (string-split m)) '(normal))))
+                        ((hed-itemized-waiton) ;; are items in hed waiting on items of waiton?
+                         (not (null? (lset-intersection eq? hed-mode '(itemmatch itemwait)))))
+                        )
 	    (debug:print-info 8 *default-log-port* "waitons: " waitons)
 	    ;; check for hed in waitons => this would be circular, remove it and issue an
 	    ;; error
 	    (if (or (member hed waitons)
 		    (member hed waitors))
@@ -386,31 +538,42 @@
 		  (debug:print-error 0 *default-log-port* "test " hed " has listed itself as a waiton or waitor, please correct this!")
 		  (set! waitons (filter (lambda (x)(not (equal? x hed))) waitons))
 		  (set! waitors (filter (lambda (x)(not (equal? x hed))) waitors))))
 	    
 	    ;; (items   (items:get-items-from-config config)))
-	    (if (not (hash-table-ref/default test-records hed #f))
-		(hash-table-set! test-records
-				 hed (vector hed     ;; 0
-					     config  ;; 1
-					     waitons ;; 2
+	    (if (not (hash-table-ref/default test-records hed #f)) ;; waiton-tconfig below will be #f until that test is visted here at least once
+		(hash-table-set! test-records ;; BB: we are doing a manual make-tests:testqueue
+				 hed (vector hed     ;; 0 ;; testname
+					     config  ;; 1 
+					     waitons ;; 2 
 					     (config-lookup config "requirements" "priority")     ;; priority 3
-					     (tests:get-items config) ;; expand the [items] and or [itemstable] into explict items
+					     (tests:get-items config) ;; 4 ;; expand the [items] and or [itemstable] into explict items
 					     #f      ;; itemsdat 5
 					     #f      ;; spare - used for item-path
 					     waitors ;; 
 					     )))
-	    (for-each 
+            ;; update waitors-upon here
+            (for-each
+             (lambda (waiton)
+               (let* ((current-waitors-upon (hash-table-ref/default waitors-upon waiton '())))
+                 (debug:print-info 8 *default-log-port* " current-waiters-upon["waiton"] is "current-waitors-upon )
+                 (when (not (member hed current-waitors-upon))
+                   (debug:print-info 8 *default-log-port* " current-waiters-upon["waiton"] << "hed  )
+                   (hash-table-set! waitors-upon waiton (cons hed current-waitors-upon)))))
+             (if (list? waitons) waitons '()))
+            (debug:print-info 8 *default-log-port* " process waitons&waitors of "hed": "(delete-duplicates (append waitons waitors)))
+            (for-each 
 	     (lambda (waiton)
 	       (if (and waiton (not (member waiton test-names)))
-		   (let* ((waiton-record   (hash-table-ref/default test-records waiton #f))
+		   (let* ((waitors-in-testpatt (runs:testpatts-mention-waitors-upon? test-patts (hash-table-ref/default waitors-upon waiton '())))
+                          (waiton-record   (hash-table-ref/default test-records waiton #f))
 			  (waiton-tconfig  (if waiton-record (vector-ref waiton-record 1) #f))
 			  (waiton-itemized (and waiton-tconfig
 						(or (hash-table-ref/default waiton-tconfig "items" #f)
 						    (hash-table-ref/default waiton-tconfig "itemstable" #f))))
 			  (itemmaps        (tests:get-itemmaps config))  ;; (configf:lookup config "requirements" "itemmap"))
-			  (new-test-patts  (tests:extend-test-patts test-patts hed waiton itemmaps)))
+			  (new-test-patts  (tests:extend-test-patts test-patts hed waiton itemmaps hed-itemized-waiton))) 
 		     (debug:print-info 0 *default-log-port* "Test " waiton " has " (if waiton-record "a" "no") " waiton-record and" (if waiton-itemized " " " no ") "items")
 		     ;; need to account for test-patt here, if I am test "a", selected with a test-patt of "hed/b%"
 		     ;; and we are waiting on "waiton" we need to add "waiton/,waiton/b%" to test-patt
 		     ;; is this satisfied by merely appending "/" to the waiton name added to the list?
 		     ;;
@@ -419,22 +582,25 @@
 		     ;; if we have this waiton already processed once we can analzye it for extending
 		     ;; tests to be run, since we can't properly process waitons unless they have been
 		     ;; initially added we add them again to be processed on second round AND add the hed
 		     ;; back in to also be processed on second round
 		     ;;
-		     (if waiton-tconfig
-			 (begin
-			   (set! test-names (cons waiton test-names)) ;; need to process this one, only add once the waiton tconfig read
-			   (if waiton-itemized
-			       (begin
-				 (debug:print-info 0 *default-log-port* "New test patts: " new-test-patts ", prev test patts: " test-patts)
-				 (set! required-tests (cons (conc waiton "/") required-tests))
-				 (set! test-patts new-test-patts))
-			       (begin
-				 (debug:print-info 0 *default-log-port* "Adding non-itemized test " waiton " to required-tests")
-				 (set! required-tests (cons waiton required-tests))
-				 (set! test-patts new-test-patts))))
+		     (if waiton-tconfig ;; BB: waiter should be in test-patts as well as the waiton have a tconfig.
+                         (if waiton-itemized
+                             (if waitors-in-testpatt
+                                 (begin
+                                   (debug:print-info 0 *default-log-port* "New test patts: " new-test-patts ", prev test patts: " test-patts)
+                                   (set! test-names (cons waiton test-names)) ;; need to process this one, only add once the waiton tconfig read
+                                   (set! required-tests (cons (conc waiton "/") required-tests))
+                                   (set! test-patts new-test-patts))
+                                 (begin
+                                   (debug:print-info 0 *default-log-port* "Waitor(s) not yet on testpatt for " waiton ", setting up to re-process it")
+                                   (set! tal (append (cons waiton tal)(list hed)))))
+                             (begin
+                               (debug:print-info 0 *default-log-port* "Adding non-itemized test " waiton " to required-tests")
+                               (set! required-tests (cons waiton required-tests))
+                               (set! test-patts new-test-patts)))
 			 (begin
 			   (debug:print-info 0 *default-log-port* "No testconfig info yet for " waiton ", setting up to re-process it")
 			   (set! tal (append (cons waiton tal)(list hed))))) ;; (cons (conc waiton "/") required-tests))
 			 
 		     ;; NOPE: didn't work. required needs to be plain test names. Try tacking on to test-patts
@@ -443,14 +609,15 @@
 		     
 		     ;; (set! test-names (cons waiton test-names))))) ;; was an append, now a cons
 		     )))
 	     (delete-duplicates (append waitons waitors)))
 	    (let ((remtests (delete-duplicates (append waitons tal))))
+              (debug:print-info 8 *default-log-port* " remtests are "remtests)
 	      (if (not (null? remtests))
 		  (begin
 		    ;; (debug:print-info 0 *default-log-port* "Preprocessing continues for " (string-intersperse remtests ", "))
-		    (loop (car remtests)(cdr remtests))))))))
+		    (loop (car remtests)(cdr remtests)))))))) ;; END test-names loop
 
     (if (not (null? required-tests))
 	(debug:print-info 1 *default-log-port* "Adding \"" (string-intersperse required-tests " ") "\" to the run queue"))
     ;; NOTE: these are all parent tests, items are not expanded yet.
     (debug:print-info 4 *default-log-port* "test-records=" (hash-table->alist test-records))
@@ -457,31 +624,27 @@
     (let ((reglen (configf:lookup *configdat* "setup" "runqueue")))
       (if (> (length (hash-table-keys test-records)) 0)
 	  (let* ((keep-going        #t)
 		 (run-queue-retries 5)
 		 (th1        (make-thread (lambda ()
-					    (runs:run-tests-queue run-id runname test-records keyvals flags test-patts required-tests (any->number reglen) all-tests-registry))
-					    ;; (handle-exceptions
-					    ;;  exn
-					    ;;  (begin
-					    ;;    (print-call-chain (current-error-port))
-					    ;;    (debug:print-error 0 *default-log-port* "failure in runs:run-tests-queue thread, error: " ((condition-property-accessor 'exn 'message) exn))
-					    ;;    (if (> run-queue-retries 0)
-					    ;; 	   (begin
-					    ;; 	     (set! run-queue-retries (- run-queue-retries 1))
-					    ;; 	     (runs:run-tests-queue run-id runname test-records keyvals flags test-patts required-tests (any->number reglen) all-tests-registry))))
-					    ;;  (runs:run-tests-queue run-id runname test-records keyvals flags test-patts required-tests (any->number reglen) all-tests-registry)))
+					    (handle-exceptions
+						exn
+						(begin
+						  (print-call-chain)
+						  (print " message: " ((condition-property-accessor 'exn 'message) exn)))
+					      (runs:run-tests-queue run-id runname test-records keyvals flags test-patts required-tests
+								    (any->number reglen) all-tests-registry)))
 					  "runs:run-tests-queue"))
-		 (th2        (make-thread (lambda ()				    
+		 (th2        (make-thread (lambda ()			 ;; BBQ: why are we visiting ALL runs here?	    
 					    ;; (rmt:find-and-mark-incomplete-all-runs))))) CAN'T INTERRUPT IT ...
 					    (let ((run-ids (rmt:get-all-run-ids)))
 					      (for-each (lambda (run-id)
 							  (if keep-going
 							      (handle-exceptions
 							       exn
 							       (debug:print 0 *default-log-port* "error in calling find-and-mark-incomplete for run-id " run-id)
-							       (rmt:find-and-mark-incomplete run-id #f)))) ;; ovr-deadtime)))
+							       (rmt:find-and-mark-incomplete run-id #f)))) ;; ovr-deadtime))) ;; could be root of https://hsdes.intel.com/appstore/article/#/220546828/main -- Title: Megatest jobs show DEAD even though they are still running (1.64/27)
 							run-ids)))
 					  "runs: mark-incompletes")))
 	    (thread-start! th1)
 	    (thread-start! th2)
 	    (thread-join! th1)
@@ -512,31 +675,52 @@
 ;;   but have items in reg; loop with (car reg)(cdr reg) '() reruns
 ;;   If reg is empty => all done
 
 (define (runs:queue-next-hed tal reg n regfull)
   (if regfull
-      (car reg)
+      (if (null? reg) #f (car reg))
       (if (null? tal) ;; tal is used up, pop from reg
-	  (car reg)
+	  (if (null? reg) #f (car reg))
 	  (car tal))))
 
 (define (runs:queue-next-tal tal reg n regfull)
   (if regfull
       tal
       (if (null? tal) ;; must transfer from reg
-	  (cdr reg)
+	  (if (null? reg) '() (cdr reg))
 	  (cdr tal))))
 
 (define (runs:queue-next-reg tal reg n regfull)
   (if regfull
-      (cdr reg)
+      (if (null? reg) '() (cdr reg)) ;; EXPLORE: reorder (cdr reg) such that looping is more efficient
       (if (null? tal) ;; if tal is null and reg not full then '() as reg contents moved to tal
 	  '()
 	  reg)))
 
+;; this is the list of parameters to the named loop "loop" near the top of runs:run-tests-queue, look around line 1216
+;;
+(define (runs:loop-values tal reg reglen regfull reruns)
+  (list (runs:queue-next-hed tal reg reglen regfull)      ;; hed
+        (runs:queue-next-tal tal reg reglen regfull)      ;; tal
+        (runs:queue-next-reg tal reg reglen regfull)      ;; reg
+        reruns))                                          ;; reruns
+
+;; objective - iterate thru tests
+;;    => want to prioritize tests we haven't seen before
+;;    => sometimes need to squeeze things in (added to reg)
+;;    => review of a previously seen test is higher priority of never visited test
+;; reg - list of previously visited tests
+;; tal - list of never visited tests
+;;   prefer next hed to be from reg than tal.
+
 (define runs:nothing-left-in-queue-count 0)
 
+;; return value of runs:expand-items is passed back to runs-tests-queue and is fed to named loop with this signature:
+;;    (let loop ((hed         (car sorted-test-names))
+;;	         (tal         (cdr sorted-test-names))
+;;	         (reg         '()) ;; registered, put these at the head of tal 
+;;	         (reruns      '()))
 (define (runs:expand-items hed tal reg reruns regfull newtal jobgroup max-concurrent-jobs run-id waitons item-path testmode test-record can-run-more items runname tconfig reglen test-registry test-records itemmaps)
   (let* ((loop-list       (list hed tal reg reruns))
 	 (prereqs-not-met (let ((res (rmt:get-prereqs-not-met run-id waitons hed item-path mode: testmode itemmaps: itemmaps)))
 			    (if (list? res)
 				res
@@ -543,15 +727,26 @@
 				(begin
 				  (debug:print 0 *default-log-port*
 					       "ERROR: rmt:get-prereqs-not-met returned non-list!\n"
 					       "  res=" res " run-id=" run-id " waitons=" waitons " hed=" hed " item-path=" item-path " testmode=" testmode " itemmaps=" itemmaps)
 				  '()))))
+         (have-itemized (not (null? (lset-intersection eq? testmode '(itemmatch itemwait)))))
 	 ;; (prereqs-not-met (mt:lazy-get-prereqs-not-met run-id waitons item-path mode: testmode itemmap: itemmap))
 	 (fails           (runs:calc-fails prereqs-not-met))
 	 (prereq-fails    (runs:calc-prereq-fail prereqs-not-met))
 	 (non-completed   (runs:calc-not-completed prereqs-not-met))
-	 (runnables       (runs:calc-runnable prereqs-not-met)))
+	 (runnables       (runs:calc-runnable prereqs-not-met))
+         (unexpanded-prereqs
+          (filter (lambda (testname)
+                    (let* ((test-rec (hash-table-ref test-records testname))
+                           (items       (tests:testqueue-get-items  test-rec)))
+                      ;;(BB> "HEY " testname "=>"items)
+                      (or (procedure? items)(eq? items 'have-procedure))))
+                  waitons))
+
+
+         )
     (debug:print-info 4 *default-log-port* "START OF INNER COND #2 "
 		      "\n can-run-more:    " can-run-more
 		      "\n testname:        " hed
 		      "\n prereqs-not-met: " (runs:pretty-string prereqs-not-met)
 		      "\n non-completed:   " (runs:pretty-string non-completed) 
@@ -566,20 +761,18 @@
 
    (cond
      ;; all prereqs met, fire off the test
      ;; or, if it is a 'toplevel test and all prereqs not met are COMPLETED then launch
 
-     ((and (not (member 'toplevel testmode))
+    ((and (not (member 'toplevel testmode))
 	   (member (hash-table-ref/default test-registry (db:test-make-full-name hed item-path) 'n/a)
 		   '(DONOTRUN removed CANNOTRUN))) ;; *common:cant-run-states-sym*) ;; '(COMPLETED KILLED WAIVED UNKNOWN INCOMPLETE)) ;; try to catch repeat processing of COMPLETED tests here
+      (debug:print-info 4 *default-log-port* "cond branch - "  "ei-1")
       (debug:print-info 1 *default-log-port* "Test " hed " set to \"" (hash-table-ref test-registry (db:test-make-full-name hed item-path)) "\". Removing it from the queue")
       (if (or (not (null? tal))
 	      (not (null? reg)))
-	  (list (runs:queue-next-hed tal reg reglen regfull)
-		(runs:queue-next-tal tal reg reglen regfull)
-		(runs:queue-next-reg tal reg reglen regfull)
-		reruns)
+          (runs:loop-values tal reg reglen regfull reruns)
 	  (begin
 	    (debug:print-info 0 *default-log-port* "Nothing left in the queue!")
 	    ;; If get here twice then we know we've tried to expand all items
 	    ;; since there must be a logic issue with the handling of loops in the 
 	    ;; items expand phase we will brute force an exit here.
@@ -588,14 +781,24 @@
 		  (debug:print 0 *default-log-port* "WARNING: this condition is triggered when there were no items to expand and nothing to run. Please check your run for completeness")
 		  (exit 0))
 		(set! runs:nothing-left-in-queue-count (+ runs:nothing-left-in-queue-count 1)))
 	    #f)))
 
-     ;; 
-     ((or (null? prereqs-not-met)
+     ;; desired result of below cond branch:
+     ;;   we want to expand items in our test of interest (hed) in the following cases:
+     ;;    case 1 - mode is itemmatch or itemwait: 
+     ;;       - all prereq tests have been expanded
+     ;;       - at least one prereq's items have completed
+     ;;    case 2 - mode is toplevel   
+     ;;       - prereqs are completed.
+     ;;       - or no prereqs can complete 
+     ;;    case 3 - mode not specified 
+     ;;       - prereqs are completed and passed (we could consider removing "and passed" -- it would change behavior from current)          
+    ((or (null? prereqs-not-met)
 	  (and (member 'toplevel testmode)
 	       (null? non-completed)))
+      (debug:print-info 4 *default-log-port* "cond branch - "  "ei-2")
       (debug:print-info 4 *default-log-port* "runs:expand-items: (or (null? prereqs-not-met) (and (member 'toplevel testmode)(null? non-completed)))")
       (let ((test-name (tests:testqueue-get-testname test-record)))
 	(setenv "MT_TEST_NAME" test-name) ;; 
 	(setenv "MT_RUNNAME"   runname)
 	(runs:set-megatest-env-vars run-id inrunname: runname) ;; these may be needed by the launching process
@@ -612,13 +815,14 @@
 		(list hed tal reg reruns))
 	      (begin
 		(debug:print-error 0 *default-log-port* "The proc from reading the items table did not yield a list - please report this")
 		(exit 1))))))
 
-     ((and (null? fails)
+    ((and (null? fails)
 	   (null? prereq-fails)
 	   (not (null? non-completed)))
+      (debug:print-info 4 *default-log-port* "cond branch - "  "ei-3")
       (let* ((allinqueue (map (lambda (x)(if (string? x) x (db:test-get-testname x)))
         		      (append newtal reruns)))
 	     ;; prereqstrs is a list of test names as strings that are prereqs for hed
              (prereqstrs (delete-duplicates (map (lambda (x)(if (string? x) x (db:test-get-testname x)))
 						 prereqs-not-met)))
@@ -643,74 +847,72 @@
 	    (let ((trimmed-tal (mt:discard-blocked-tests run-id hed tal test-records))
 		  (trimmed-reg (mt:discard-blocked-tests run-id hed reg test-records)))
 	      (debug:print 1 *default-log-port* "WARNING: test " hed " has discarded prerequisites, removing it from the queue")
 
 	      (let ((test-id (rmt:get-test-id run-id hed "")))
-		(if test-id (mt:test-set-state-status-by-id run-id test-id "NOT_STARTED" "PREQ_DISCARDED" "Failed to run due to discarded prerequisites")))
+		(if test-id (mt:test-set-state-status-by-id run-id test-id "COMPLETED" "PREQ_DISCARDED" "Failed to run due to discarded prerequisites")))
 	      
 	      (if (and (null? trimmed-tal)
 		       (null? trimmed-reg))
 		  #f
-		  (list (runs:queue-next-hed trimmed-tal trimmed-reg reglen regfull)
-			(runs:queue-next-tal trimmed-tal trimmed-reg reglen regfull)
-			(runs:queue-next-reg trimmed-tal trimmed-reg reglen regfull)
-			reruns)))
+                  (runs:loop-values trimmed-tal trimmed-reg reglen regfull reruns)
+                  ))
 	      (list (car newtal)(append (cdr newtal) reg) '() reruns))))
 
-     ((and (null? fails)
+    ((and (null? fails) ;; have not-started tests, but unable to run them.  everything looks completed with no prospect of unsticking something that is stuck.  we should mark hed as moribund and exit or continue if there are more tests to consider
 	   (null? prereq-fails)
 	   (null? non-completed))
+     (debug:print-info 4 *default-log-port* "cond branch - "  "ei-4")
       (if  (runs:can-keep-running? hed 20)
 	  (begin
 	    (runs:inc-cant-run-tests hed)
-	    (debug:print-info 1 *default-log-port* "no fails in prerequisites for " hed " but also none running, keeping " hed " for now. Try count: " (hash-table-ref/default *seen-cant-run-tests* hed 0))
+	    (debug:print-info 0 *default-log-port* "no fails in prerequisites for " hed " but also none running, keeping " hed " for now. Try count: " (hash-table-ref/default *seen-cant-run-tests* hed 0)) ;; 
 	    ;; getting here likely means the system is way overloaded, kill a full minute before continuing
-	    (thread-sleep! 60)
+	    (thread-sleep! 60) ;; TODO: gate by normalized server load > 1.0 (maxload config thing)
 	    ;; num-retries code was here
 	    ;; we use this opportunity to move contents of reg to tal
 	    (list (car newtal)(append (cdr newtal) reg) '() reruns)) ;; an issue with prereqs not yet met?
 	  (begin
 	    (debug:print-info 1 *default-log-port* "no fails in prerequisites for " hed " but nothing seen running in a while, dropping test " hed " from the run queue")
 	    (let ((test-id (rmt:get-test-id run-id hed "")))
 	      (if test-id (mt:test-set-state-status-by-id run-id test-id "NOT_STARTED" "TIMED_OUT" "Nothing seen running in a while.")))
-	    (list (runs:queue-next-hed tal reg reglen regfull)
-		  (runs:queue-next-tal tal reg reglen regfull)
-		  (runs:queue-next-reg tal reg reglen regfull)
-		  reruns))))
+            (runs:loop-values tal reg reglen regfull reruns)
+            )))
 
-     ((and 
+    ((and 
        (or (not (null? fails))
 	   (not (null? prereq-fails)))
        (member 'normal testmode))
+      (debug:print-info 4 *default-log-port* "cond branch - "  "ei-5")
       (debug:print-info 1 *default-log-port* "test "  hed " (mode=" testmode ") has failed prerequisite(s); "
 			(string-intersperse (map (lambda (t)(conc (db:test-get-testname t) ":" (db:test-get-state t)"/"(db:test-get-status t))) fails) ", ")
 			", removing it from to-do list")
       (let ((test-id (rmt:get-test-id run-id hed "")))
 	(if test-id
 	    (if (not (null? prereq-fails))
-		(mt:test-set-state-status-by-id run-id test-id "NOT_STARTED" "PREQ_DISCARDED" "Failed to run due to prior failed prerequisites")
-		(mt:test-set-state-status-by-id run-id test-id "NOT_STARTED" "PREQ_FAIL"      "Failed to run due to failed prerequisites"))))
+		(mt:test-set-state-status-by-id run-id test-id "COMPLETED" "PREQ_DISCARDED" "Failed to run due to prior failed prerequisites")
+		(mt:test-set-state-status-by-id run-id test-id "COMPLETED" "PREQ_FAIL"      "Failed to run due to failed prerequisites"))))
+      ;; (debug:print 4 *default-log-port*"BB> set PREQ_FAIL on "hed)
+      ;; (mt:test-set-state-status-by-id run-id test-id "NOT_STARTED" "PREQ_FAIL"      "Failed to run due to failed prerequisites")))) ;; BB: this works, btu equivalent for itemwait mode does not work.
       (if (or (not (null? reg))(not (null? tal)))
 	  (begin
 	    (hash-table-set! test-registry hed 'CANNOTRUN)
-	    (list (runs:queue-next-hed tal reg reglen regfull)
-		  (runs:queue-next-tal tal reg reglen regfull)
-		  (runs:queue-next-reg tal reg reglen regfull)
-		  (cons hed reruns)))
+            (runs:loop-values tal reg reglen regfull (cons hed reruns))
+            )
 	  #f)) ;; #f flags do not loop
-
+      
      ((and (not (null? fails))(member 'toplevel testmode))
+      (debug:print-info 4 *default-log-port* "cond branch - "  "ei-6")
       (if (or (not (null? reg))(not (null? tal)))
 	   (list (car newtal)(append (cdr newtal) reg) '() reruns)
 	  #f)) 
-     ((null? runnables) #f) ;; if we get here and non-completed is null then it is all over.
+     ((null? runnables)
+      (debug:print-info 4 *default-log-port* "cond branch - "  "ei-7")
+      #f) ;; if we get here and non-completed is null then it is all over.
      (else
+      (debug:print-info 4 *default-log-port* "cond branch - "  "ei-8")
       (debug:print 0 *default-log-port* "WARNING: FAILS or incomplete tests maybe preventing completion of this run. Watch for issues with test " hed ", continuing for now")
-      ;; (list (runs:queue-next-hed tal reg reglen regfull)
-      ;;   	(runs:queue-next-tal tal reg reglen regfull)
-      ;;   	(runs:queue-next-reg tal reg reglen regfull)
-      ;;   	reruns)
       (list (car newtal)(cdr newtal) reg reruns)))))
 
 (define (runs:mixed-list-testname-and-testrec->list-of-strings inlst)
   (if (null? inlst)
       '()
@@ -730,10 +932,13 @@
 
 
 ;;  hed tal reg reruns reglen regfull test-record runname test-name item-path jobgroup max-concurrent-jobs run-id waitons item-path testmode test-patts required-tests test-registry registry-mutex flags keyvals run-info newtal all-tests-registry itemmaps)
 (define (runs:process-expanded-tests runsdat testdat)
   ;; unroll the contents of runsdat and testdat (due to ongoing refactoring).
+  (debug:print 2 *default-log-port* "runs:process-expanded-tests; testdat:" )
+  (debug:print 2 *default-log-port* (with-output-to-string
+                                            (lambda () (pp (runs:testdat->alist testdat) ))))
   (let* ((hed                    (runs:testdat-hed testdat))
 	 (tal                    (runs:testdat-tal testdat))
 	 (reg                    (runs:testdat-reg testdat))
 	 (reruns                 (runs:testdat-reruns testdat))
 	 (test-name              (runs:testdat-test-name testdat))
@@ -767,11 +972,11 @@
 	 (num-running-in-jobgroup(list-ref run-limits-info 2)) 
 	 (max-concurrent-jobs    (list-ref run-limits-info 3))
 	 (job-group-limit        (list-ref run-limits-info 4))
 	 ;; (prereqs-not-met        (rmt:get-prereqs-not-met run-id waitons hed item-path mode: testmode itemmaps: itemmaps))
 	 ;; (prereqs-not-met         (mt:lazy-get-prereqs-not-met run-id waitons item-path mode: testmode itemmap: itemmap))
-	 (fails                  (if (list? prereqs-not-met)
+	 (fails                  (if (list? prereqs-not-met) ;; TODO: rename fails to failed-prereqs
 				      (runs:calc-fails prereqs-not-met)
 				      (begin
 					(debug:print-error 0 *default-log-port* "prereqs-not-met is not a list! " prereqs-not-met)
 					'())))
 	 (non-completed           (filter (lambda (x)             ;; remove hed from not completed list, duh, of course it is not completed!
@@ -778,12 +983,13 @@
 					    (not (equal? x hed)))
 					  (runs:calc-not-completed prereqs-not-met)))
 	 (loop-list               (list hed tal reg reruns))
 	 ;; configure the load runner
 	 (numcpus                 (common:get-num-cpus #f))
-	 (maxload                 (string->number (or (configf:lookup *configdat* "jobtools" "maxload") "3")))
-	 (waitdelay               (string->number (or (configf:lookup *configdat* "jobtools" "waitdelay") "60"))))
+	 (maxload                 (string->number (or (configf:lookup *configdat* "jobtools" "maxload") "3.0")))         ;; use a non-number string to disable
+         (maxhomehostload         (string->number (or (configf:lookup *configdat* "jobtools" "maxhomehostload") "1.2"))) ;; use a non-number string to disable
+         (waitdelay               (string->number (or (configf:lookup *configdat* "jobtools" "waitdelay") "60"))))
     (debug:print-info 4 *default-log-port* "have-resources: " have-resources " prereqs-not-met: (" 
 		      (string-intersperse 
 		       (map (lambda (t)
 			      (if (vector? t)
 				  (conc (db:test-get-state t) "/" (db:test-get-status t))
@@ -800,23 +1006,20 @@
 
     ;; Don't know at this time if the test have been launched at some time in the past
     ;; i.e. is this a re-launch?
     (debug:print-info 4 *default-log-port* "run-limits-info = " run-limits-info)
     
-    (cond
+    (cond ; cond 894- 1067
      
      ;; Check item path against item-patts, 
      ;;
      ((not (tests:match test-patts (tests:testqueue-get-testname test-record) item-path required: required-tests)) ;; This test/itempath is not to be run
       ;; else the run is stuck, temporarily or permanently
       ;; but should check if it is due to lack of resources vs. prerequisites
       (debug:print-info 1 *default-log-port* "Skipping " (tests:testqueue-get-testname test-record) " " item-path " as it doesn't match " test-patts)
       (if (or (not (null? tal))(not (null? reg)))
-	  (list (runs:queue-next-hed tal reg reglen regfull)
-		(runs:queue-next-tal tal reg reglen regfull)
-		(runs:queue-next-reg tal reg reglen regfull)
-		reruns)
+	  (runs:loop-values tal reg reglen regfull reruns)
 	  #f))
      
      ;; Register tests 
      ;;
      ((not (hash-table-ref/default test-registry (db:test-make-full-name test-name item-path) #f))
@@ -837,11 +1040,11 @@
 	    (if (rmt:get-test-id run-id test-name "")
 		(hash-table-set! test-registry (db:test-make-full-name test-name "") 'done))))
       (runs:shrink-can-run-more-tests-count runsdat)   ;; DELAY TWEAKER (still needed?)
       (if (and (null? tal)(null? reg))
 	  (list hed tal (append reg (list hed)) reruns)
-	  (list (runs:queue-next-hed tal reg reglen regfull)
+	  (list (runs:queue-next-hed tal reg reglen regfull) ;; cannot replace with a call to runs:loop-values as the logic is different for reg
 		(runs:queue-next-tal tal reg reglen regfull)
 		;; NB// Here we are building reg as we register tests
 		;; if regfull we must pop the front item off reg
 		(if regfull
 		    (append (cdr reg) (list hed))
@@ -883,22 +1086,22 @@
       ;; we are going to reset all the counters for test retries by setting a new hash table
       ;; this means they will increment only when nothing can be run
       (set! *max-tries-hash* (make-hash-table))
       ;; well, first lets see if cpu load throttling is enabled. If so wait around until the
       ;; average cpu load is under the threshold before continuing
-      (if (configf:lookup *configdat* "jobtools" "maxload") ;; only gate if maxload is specified
-	  (common:wait-for-cpuload maxload numcpus waitdelay))
+      (if maxload ;; only gate if maxload is specified
+          (common:wait-for-cpuload maxload numcpus waitdelay))
+      (if maxhomehostload
+          (common:wait-for-homehost-load maxhomehostload (conc "Waiting for homehost load to drop below normalized value of " maxhomehostload)))
+      
       (run:test run-id run-info keyvals runname test-record flags #f test-registry all-tests-registry)
       (runs:incremental-print-results run-id)
       (hash-table-set! test-registry (db:test-make-full-name test-name item-path) 'running)
       (runs:shrink-can-run-more-tests-count runsdat)  ;; DELAY TWEAKER (still needed?)
       ;; (thread-sleep! *global-delta*)
       (if (or (not (null? tal))(not (null? reg)))
-	  (list (runs:queue-next-hed tal reg reglen regfull)
-		(runs:queue-next-tal tal reg reglen regfull)
-		(runs:queue-next-reg tal reg reglen regfull)
-		reruns)
+	  (runs:loop-values tal reg reglen regfull reruns)
 	  #f))
      
      ;; must be we have unmet prerequisites
      ;;
      (else
@@ -918,68 +1121,67 @@
 	    (if  (runs:lownoise "Waiting for more work to do..." 60)
 		 (debug:print-info 0 *default-log-port* "Waiting for more work to do..."))
 	    (thread-sleep! 1)
 	    (list (car newtal)(cdr newtal) reg reruns))
 	  ;; the waiton is FAIL so no point in trying to run hed ever again
-	  (if (or (not (null? reg))(not (null? tal)))
-	      (if (vector? hed)
+	  (begin
+            (let ((my-test-id (rmt:get-test-id run-id test-name item-path)))
+              (mt:test-set-state-status-by-id run-id my-test-id "COMPLETED" "PREQ_FAIL" "Failed to run due to failed prerequisites2"))
+
+
+            
+            (if (or (not (null? reg))(not (null? tal)))
+                (if (vector? hed)
 		  (begin
 		    (debug:print 1 *default-log-port* "WARNING: Dropping test " test-name "/" item-path
 				 " from the launch list as it has prerequistes that are FAIL")
 		    (let ((test-id (rmt:get-test-id run-id hed "")))
-		      (if test-id (mt:test-set-state-status-by-id run-id test-id "NOT_STARTED" "PREQ_FAIL" "Failed to run due to failed prerequisites")))
+		      (if test-id (mt:test-set-state-status-by-id run-id test-id "COMPLETED" "PREQ_FAIL" "Failed to run due to failed prerequisites")))
 		    (runs:shrink-can-run-more-tests-count runsdat) ;; DELAY TWEAKER (still needed?)
 		    ;; (thread-sleep! *global-delta*)
 		    ;; This next is for the items
-		    (mt:test-set-state-status-by-testname run-id test-name item-path "NOT_STARTED" "BLOCKED" #f)
+
+                    (if (not (null? fails))
+                        ;;(mt:test-set-state-status-by-testname run-id test-name item-path "NOT_STARTED" "PREQ_FAIL" #f)
+                        (rmt:set-state-status-and-roll-up-items run-id test-name item-path "NOT_STARTED" "PREQ_FAIL" #f) 
+                        ;;(mt:test-set-state-status-by-testname run-id test-name item-path "NOT_STARTED" "BLOCKED" #f)
+                        (rmt:set-state-status-and-roll-up-items run-id test-name item-path "NOT_STARTED" "BLOCKED" #f) )
 		    (hash-table-set! test-registry (db:test-make-full-name test-name item-path) 'removed)
-		    (list (runs:queue-next-hed tal reg reglen regfull)
-			  (runs:queue-next-tal tal reg reglen regfull)
-			  (runs:queue-next-reg tal reg reglen regfull)
-			  reruns ;; WAS: (cons hed reruns) ;; but that makes no sense?
-			  ))
-		  (let ((nth-try (hash-table-ref/default test-registry hed 0)))
+		    (runs:loop-values tal reg reglen regfull reruns))
+		  (let ((nth-try (hash-table-ref/default test-registry hed 0))) ;; hed not a vector...
+                    (debug:print 2 *default-log-port* "nth-try("hed")="nth-try)
 		    (cond
 		     ((member "RUNNING" (map db:test-get-state prereqs-not-met))
 		      (if (runs:lownoise (conc "possible RUNNING prerequistes " hed) 60)
 			  (debug:print 0 *default-log-port* "WARNING: test " hed " has possible RUNNING prerequisites, don't give up on it yet."))
-		      (thread-sleep! 4)
-		      (list (runs:queue-next-hed newtal reg reglen regfull)
-			    (runs:queue-next-tal newtal reg reglen regfull)
-			    (runs:queue-next-reg newtal reg reglen regfull)
-			    reruns))
-		     ((or (not nth-try)
+		      (thread-sleep! 0.1)
+		      (runs:loop-values tal reg reglen regfull reruns))
+		     ((or (not nth-try) ;; BB: condition on subsequent tries, condition below fires on first try 
 			  (and (number? nth-try)
-			       (< nth-try 10)))
+			       (< nth-try 2)))
 		      (hash-table-set! test-registry hed (if (number? nth-try)
 							     (+ nth-try 1)
 							     0))
 		      (if (runs:lownoise (conc "not removing test " hed) 60)
 			  (debug:print 1 *default-log-port* "WARNING: not removing test " hed " from queue although it may not be runnable due to FAILED prerequisites"))
 		      ;; may not have processed correctly. Could be a race condition in your test implementation? Dropping test " hed) ;;  " as it has prerequistes that are FAIL. (NOTE: hed is not a vector)")
 		      (runs:shrink-can-run-more-tests-count runsdat) ;; DELAY TWEAKER (still needed?)
-		      ;; (list hed tal reg reruns)
-		      ;; (list (car newtal)(cdr newtal) reg reruns)
-		      ;; (hash-table-set! test-registry hed 'removed)
-		      (list (runs:queue-next-hed newtal reg reglen regfull)
-			    (runs:queue-next-tal newtal reg reglen regfull)
-			    (runs:queue-next-reg newtal reg reglen regfull)
-			    reruns))
-		     ((symbol? nth-try)
+		      (runs:loop-values newtal reg reglen regfull reruns))
+		     ((symbol? nth-try) ;; BB: 'done matches here in one case where prereq itemwait failed.  This is first "try"
 		      (if (eq? nth-try 'removed) ;; removed is removed - drop it NOW
 			  (if (null? tal)
 			      #f ;; yes, really
 			      (list (car tal)(cdr tal) reg reruns))
 			  (begin
 			    (if (runs:lownoise (conc "FAILED prerequisites or other issue" hed) 60)
-				(debug:print 0 *default-log-port* "WARNING: test " hed " has FAILED prerequisites or other issue. Internal state " nth-try " will be overridden and we'll retry."))
-			    (mt:test-set-state-status-by-testname run-id test-name item-path "NOT_STARTED" "KEEP_TRYING" #f)
-			    (hash-table-set! test-registry hed 0)
-			    (list (runs:queue-next-hed newtal reg reglen regfull)
-				  (runs:queue-next-tal newtal reg reglen regfull)
-				  (runs:queue-next-reg newtal reg reglen regfull)
-				  reruns))))
+				(debug:print 0 *default-log-port* "WARNING: test " hed " has FAILED prerequisites or other issue. Internal state >" nth-try "< will be overridden and we'll retry."))
+			    ;; was: (mt:test-set-state-status-by-testname run-id test-name item-path "NOT_STARTED" "KEEP_TRYING" #f)
+                            (mt:test-set-state-status-by-testname run-id test-name item-path "COMPLETED" "PREQ_FAIL" #f)
+			    (hash-table-set! test-registry hed 'removed) ;; was 0
+                            (if (not (and (null? reg) (null? tal)))
+                                (runs:loop-values tal reg reglen regfull reruns)
+                                #f))))
 		     (else
 		      (if (runs:lownoise (conc "FAILED prerequitests and we tried" hed) 60)
 			  (debug:print 0 *default-log-port* "WARNING: test " hed " has FAILED prerequitests and we've tried at least 10 times to run it. Giving up now."))
 		      ;; (debug:print 0 *default-log-port* "         prereqs: " prereqs-not-met)
 		      (hash-table-set! test-registry hed 'removed)
@@ -988,18 +1190,20 @@
 		      (rmt:set-state-status-and-roll-up-items run-id test-name item-path #f "FAIL" #f) ;; treat as FAIL
 		      (list (if (null? tal)(car newtal)(car tal))
 			    tal
 			    reg
 			    reruns)))))
-	      ;; can't drop this - maybe running? Just keep trying
-	      (let ((runable-tests (runs:runable-tests prereqs-not-met)))
-		(if (null? runable-tests)
-		    #f   ;; I think we are truly done here
-		    (list (runs:queue-next-hed newtal reg reglen regfull)
-			    (runs:queue-next-tal newtal reg reglen regfull)
-			    (runs:queue-next-reg newtal reg reglen regfull)
-			    reruns)))))))))
+                ;; ELSE: can't drop this - maybe running? Just keep trying
+
+                ;;(if (not (or (not (null? reg))(not (null? tal)))) ;; old experiment
+                (let ((runable-tests (runs:runable-tests prereqs-not-met))) ;; SUSPICIOUS: Should look at more than just prereqs-not-met?
+                  (if (null? runable-tests)
+                      #f   ;; I think we are truly done here
+                      (runs:loop-values newtal reg reglen regfull reruns)))
+                ;;) ;;from old experiment
+                ) ;; end if (or (not (null? reg))(not (null? tal)))
+            ))))))
 
 ;; scan a list of tests looking to see if any are potentially runnable
 ;;
 (define (runs:runable-tests tests)
   (filter (lambda (t)
@@ -1028,11 +1232,11 @@
    inc-results-fmt: "~12a~12a~20a~12a~40a\n" ;; state status time duration test-name item-path
    run-info: #f
    runname: #f
    target: #f
    )
-)
+  )
 
 (define (runs:incremental-print-results run-id)
   (let ((curr-sec (current-seconds)))
     (if (> (- curr-sec (runs:gendat-inc-results-last-update *runs:general-data*)) 5) ;; at least five seconds since last update
 	(let* ((run-dat  (or (runs:gendat-run-info *runs:general-data*)(rmt:get-run-info run-id)))
@@ -1098,54 +1302,51 @@
 
   ;; Do mark-and-find clean up of db before starting runing of quue
   ;;
   ;; (rmt:find-and-mark-incomplete)
 
-  (let* ((run-info             (rmt:get-run-info run-id))
-	(tests-info            (mt:get-tests-for-run run-id #f '() '())) ;;  qryvals: "id,testname,item_path"))
-	(sorted-test-names     (tests:sort-by-priority-and-waiton test-records))
-	(test-registry         (make-hash-table))
-	(registry-mutex        (make-mutex))
-	(num-retries           0)
-	(max-retries           (config-lookup *configdat* "setup" "maxretries"))
-	(max-concurrent-jobs   (let ((mcj (config-lookup *configdat* "setup"     "max_concurrent_jobs")))
-				 (if (and mcj (string->number mcj))
-				     (string->number mcj)
-				     1))) ;; length of the register queue ahead
-	(reglen                (if (number? reglen-in) reglen-in 1))
-	(last-time-incomplete  (- (current-seconds) 900)) ;; force at least one clean up cycle
-	(last-time-some-running (current-seconds))
-	;; (tdbdat                (tasks:open-db))
-	(runsdat (make-runs:dat
-		  ;; hed: hed
-		  ;; tal: tal
-		  ;; reg: reg
-		  ;; reruns: reruns
-		  reglen: reglen
-		  regfull: #f ;; regfull
-		  ;; test-record: test-record
-		  runname: runname
-		  ;; test-name: test-name
-		  ;; item-path: item-path
-		  ;; jobgroup: jobgroup
-		  max-concurrent-jobs: max-concurrent-jobs
-		  run-id: run-id
-		  ;; waitons: waitons
-		  ;; testmode: testmode
-		  test-patts: test-patts
-		  required-tests: required-tests
-		  test-registry: test-registry
-		  registry-mutex: registry-mutex
-		  flags: flags
-		  keyvals: keyvals
-		  run-info: run-info
-		  ;; newtal: newtal
-		  all-tests-registry: all-tests-registry
-		  ;; itemmaps: itemmaps
-		  ;; prereqs-not-met: (rmt:get-prereqs-not-met run-id waitons hed item-path mode: testmode itemmaps: itemmaps)
-		  ;; can-run-more-tests: (runs:can-run-more-tests run-id jobgroup max-concurrent-jobs) ;; look at the test jobgroup and tot jobs running
-		  )))
+  (let* ((run-info              (rmt:get-run-info run-id))
+         (tests-info            (mt:get-tests-for-run run-id #f '() '())) ;;  qryvals: "id,testname,item_path"))
+         (sorted-test-names     (tests:sort-by-priority-and-waiton test-records))
+         (test-registry         (make-hash-table))
+         (registry-mutex        (make-mutex))
+         (num-retries           0)
+         (max-retries           (config-lookup *configdat* "setup" "maxretries"))
+         (max-concurrent-jobs   (configf:lookup-number *configdat* "setup" "max_concurrent_jobs" default: 50))
+         (reglen                (if (number? reglen-in) reglen-in 1))
+         (last-time-incomplete  (- (current-seconds) 900)) ;; force at least one clean up cycle
+         (last-time-some-running (current-seconds))
+         ;; (tdbdat                (tasks:open-db))
+         (runsdat (make-runs:dat
+                   ;; hed: hed
+                   ;; tal: tal
+                   ;; reg: reg
+                   ;; reruns: reruns
+                   reglen: reglen
+                   regfull: #f ;; regfull
+                   ;; test-record: test-record
+                   runname: runname
+                   ;; test-name: test-name
+                   ;; item-path: item-path
+                   ;; jobgroup: jobgroup
+                   max-concurrent-jobs: max-concurrent-jobs
+                   run-id: run-id
+                   ;; waitons: waitons
+                   ;; testmode: testmode
+                   test-patts: test-patts
+                   required-tests: required-tests
+                   test-registry: test-registry
+                   registry-mutex: registry-mutex
+                   flags: flags
+                   keyvals: keyvals
+                   run-info: run-info
+                   ;; newtal: newtal
+                   all-tests-registry: all-tests-registry
+                   ;; itemmaps: itemmaps
+                   ;; prereqs-not-met: (rmt:get-prereqs-not-met run-id waitons hed item-path mode: testmode itemmaps: itemmaps)
+                   ;; can-run-more-tests: (runs:can-run-more-tests run-id jobgroup max-concurrent-jobs) ;; look at the test jobgroup and tot jobs running
+                   )))
 
     ;; Initialize the test-registery hash with tests that already have a record
     ;; convert state to symbol and use that as the hash value
     (for-each (lambda (trec)
 		(let ((id (db:test-get-id        trec))
@@ -1156,14 +1357,16 @@
 		      (hash-table-set! test-registry (db:test-make-full-name tn ip) (string->symbol st)))))
 	      tests-info)
     (set! max-retries (if (and max-retries (string->number max-retries))(string->number max-retries) 100))
 
     (let loop ((hed         (car sorted-test-names))
-	       (tal         (cdr sorted-test-names))
+               (tal         (cdr sorted-test-names))
 	       (reg         '()) ;; registered, put these at the head of tal 
 	       (reruns      '()))
 
+      
+      
       (runs:incremental-print-results run-id)
 
       (if (not (null? reruns))(debug:print-info 4 *default-log-port* "reruns=" reruns))
 
       ;; Here we mark any old defunct tests as incomplete. Do this every fifteen minutes
@@ -1207,20 +1410,24 @@
 			   itemmaps:    itemmaps
 			   ;; prereqs-not-met: prereqs-not-met
 			   )))
 	(runs:dat-regfull-set! runsdat regfull)
 
+        ;; -- removed BB 17ww28 - no longer needed.
 	;; every 15 minutes verify the server is there for this run
-	(if (and (common:low-noise-print 240 "try start server"  run-id)
-		 (not (server:check-if-running *toppath*)))
-	    (server:kind-run *toppath*))
+	;; (if (and (common:low-noise-print 240 "try start server"  run-id)
+	;; 	 (not (or (and *runremote*
+	;; 		       (remote-server-url *runremote*)
+	;; 		       (server:ping (remote-server-url *runremote*)))
+	;; 		  (server:check-if-running *toppath*))))
+	;;     (server:kind-run *toppath*))
 	
 	(if (> num-running 0)
-	  (set! last-time-some-running (current-seconds)))
+            (set! last-time-some-running (current-seconds)))
 
-      (if (> (current-seconds)(+ last-time-some-running (or (configf:lookup *configdat* "setup" "give-up-waiting") 36000)))
-	  (hash-table-set! *max-tries-hash* tfullname (+ (hash-table-ref/default *max-tries-hash* tfullname 0) 1)))
+        (if (> (current-seconds)(+ last-time-some-running (or (configf:lookup *configdat* "setup" "give-up-waiting") 36000)))
+            (hash-table-set! *max-tries-hash* tfullname (+ (hash-table-ref/default *max-tries-hash* tfullname 0) 1)))
 	;; (debug:print 0 *default-log-port* "max-tries-hash: " (hash-table->alist *max-tries-hash*))
 
 	;; Ensure all top level tests get registered. This way they show up as "NOT_STARTED" on the dashboard
 	;; and it is clear they *should* have run but did not.
 	(if (not (hash-table-ref/default test-registry (db:test-make-full-name test-name "") #f))
@@ -1238,28 +1445,29 @@
 	      (if (or (not (null? tal))(not (null? reg)))
 		  (loop (runs:queue-next-hed tal reg reglen regfull)
 			(runs:queue-next-tal tal reg reglen regfull)
 			(runs:queue-next-reg tal reg reglen regfull)
 			reruns))))
-		  ;; (loop (car tal)(cdr tal) reg reruns))))
+        ;; (loop (car tal)(cdr tal) reg reruns))))
 
 	(runs:incremental-print-results run-id)
 	(debug:print 4 *default-log-port* "TOP OF LOOP => "
 		     "test-name: " test-name
-		     "\n  test-record  " test-record
 		     "\n  hed:         " hed
-		     "\n  itemdat:     " itemdat
+		     "\n  tal:         " tal
+		     "\n  reg:         " reg
+                     "\n  test-record  " test-record
+                     "\n  itemdat:     " itemdat
 		     "\n  items:       " items
 		     "\n  item-path:   " item-path
 		     "\n  waitons:     " waitons
 		     "\n  num-retries: " num-retries
-		     "\n  tal:         " tal
-		     "\n  reruns:      " reruns
+                     "\n  reruns:      " reruns
 		     "\n  regfull:     " regfull
 		     "\n  reglen:      " reglen
 		     "\n  length reg:  " (length reg)
-		     "\n  reg:         " reg)
+                     )
 
 	;; check for hed in waitons => this would be circular, remove it and issue an
 	;; error
 	(if (member test-name waitons)
 	    (begin
@@ -1279,88 +1487,109 @@
 				   (if (and (not (member waiton tal))            ;; this waiton is not in the list to be tried to run
 					    (not (member waiton reruns)))
 				       1
 				       #f))
 				 waitons))))) ;; could do this more elegantly with a marker....
+          (debug:print-info 4 *default-log-port* "cond branch - "  "rtq-1")
 	  (debug:print 0 *default-log-port* "WARNING: Marking test " tfullname " as not runnable. It is waiting on tests that cannot be run. Giving up now.")
 	  (hash-table-set! test-registry tfullname 'removed))
 
 	 ;; items is #f then the test is ok to be handed off to launch (but not before)
 	 ;; 
 	 ((not items)
+          (debug:print-info 4 *default-log-port* "cond branch - "  "rtq-2")
 	  (debug:print-info 4 *default-log-port* "OUTER COND: (not items)")
 	  (if (and (not (tests:match test-patts (tests:testqueue-get-testname test-record) item-path required: required-tests))
 		   (not (null? tal)))
 	      (loop (car tal)(cdr tal) reg reruns))
 	  (runs:testdat-prereqs-not-met-set! testdat (rmt:get-prereqs-not-met run-id waitons hed item-path mode: testmode itemmaps: itemmaps))
 	  (runs:dat-can-run-more-tests-set! runsdat (runs:can-run-more-tests runsdat run-id jobgroup max-concurrent-jobs)) ;; look at the test jobgroup and tot jobs running
 	  (let ((loop-list (runs:process-expanded-tests runsdat testdat)))
-	      (if loop-list (apply loop loop-list))))
+            (if loop-list (apply loop loop-list))))
 
 	 ;; items processed into a list but not came in as a list been processed
 	 ;;
 	 ((and (list? items)     ;; thus we know our items are already calculated
 	       (not   itemdat))  ;; and not yet expanded into the list of things to be done
+          (debug:print-info 4 *default-log-port* "cond branch - "  "rtq-3")
 	  (debug:print-info 4 *default-log-port* "OUTER COND: (and (list? items)(not itemdat))")
 	  ;; Must determine if the items list is valid. Discard the test if it is not.
 	  (if (and (list? items)
 		   (> (length items) 0)
 		   (and (list? (car items))
 			(> (length (car items)) 0))
 		   (debug:debug-mode 1))
 	      (debug:print 2 *default-log-port* (map (lambda (row)
-				    (conc (string-intersperse
-					   (map (lambda (varval)
-						  (string-intersperse varval "="))
-						row)
-					   " ")
-					  "\n"))
-				  items)))
-	  (for-each
-	   (lambda (my-itemdat)
-	     (let* ((new-test-record (let ((newrec (make-tests:testqueue)))
-				       (vector-copy! test-record newrec)
-				       newrec))
-		    (my-item-path (item-list->path my-itemdat)))
-	       (if (tests:match test-patts hed my-item-path required: required-tests) ;; (patt-list-match my-item-path item-patts)           ;; yes, we want to process this item, NOTE: Should not need this check here!
-		   (let ((newtestname (db:test-make-full-name hed my-item-path)))    ;; test names are unique on testname/item-path
-		     (tests:testqueue-set-items!     new-test-record #f)
-		     (tests:testqueue-set-itemdat!   new-test-record my-itemdat)
-		     (tests:testqueue-set-item_path! new-test-record my-item-path)
-		     (hash-table-set! test-records newtestname new-test-record)
-		     (set! tal (append tal (list newtestname))))))) ;; since these are itemized create new test names testname/itempath
-	   items)
-
-	  ;; (debug:print-info 0 *default-log-port* "Test " (tests:testqueue-get-testname test-record) " is itemized but has no items")
+                                                       (conc (string-intersperse
+                                                              (map (lambda (varval)
+                                                                     (string-intersperse varval "="))
+                                                                   row)
+                                                              " ")
+                                                             "\n"))
+                                                     items)))
+
+          (let* ((items-in-testpatt
+                  (filter
+                   (lambda (my-itemdat)
+                     (tests:match test-patts hed (item-list->path my-itemdat) ))
+                   ;; was: (tests:match test-patts hed (item-list->path my-itemdat) required: required-tests))
+                   items) ))
+            (if (null? items-in-testpatt)
+                (let ((test-id   (rmt:get-test-id run-id test-name "")))
+                  (debug:print-info 0 *default-log-port* "Test " (tests:testqueue-get-testname test-record) " is itemized but has no items matching test pattern -- marking status ZERO_ITEMS")
+                  (if test-id
+                      (mt:test-set-state-status-by-id run-id test-id "NOT_STARTED" "ZERO_ITEMS" "This test has no items which match test pattern.")))
+                
+                (for-each (lambda (my-itemdat)
+                            (let* ((new-test-record (let ((newrec (make-tests:testqueue)))
+                                                      (vector-copy! test-record newrec)
+                                                      newrec))
+                                   (my-item-path (item-list->path my-itemdat))
+
+                                   (newtestname (db:test-make-full-name hed my-item-path)))    ;; test names are unique on testname/item-path
+                              (tests:testqueue-set-items!     new-test-record #f)
+                              (tests:testqueue-set-itemdat!   new-test-record my-itemdat)
+                              (tests:testqueue-set-item_path! new-test-record my-item-path)
+                              (hash-table-set! test-records newtestname new-test-record)
+                              (set! tal (append tal (list newtestname)))))  ;; since these are itemized create new test names testname/itempath
+                          items-in-testpatt)))
+          
+          
 
 	  ;; At this point we have possibly added items to tal but all must be handed off to 
 	  ;; INNER COND logic. I think loop without rotating the queue 
 	  ;; (loop hed tal reg reruns))
 	  ;; (let ((newtal (append tal (list hed))))  ;; We should discard hed as it has been expanded into it's items? Yes, but only if this *is* an itemized test
 	  ;; (loop (car newtal)(cdr newtal) reg reruns)
 	  (if (null? tal)
 	      #f
 	      (loop (car tal)(cdr tal) reg reruns)))
-	    
+         
 	 ;; if items is a proc then need to run items:get-items-from-config, get the list and loop 
 	 ;;    - but only do that if resources exist to kick off the job
 	 ;; EXPAND ITEMS
 	 ((or (procedure? items)(eq? items 'have-procedure))
+          (debug:print-info 4 *default-log-port* "cond branch - "  "rtq-4")
 	  (let ((can-run-more    (runs:can-run-more-tests runsdat run-id jobgroup max-concurrent-jobs)))
 	    (if (and (list? can-run-more)
 		     (car can-run-more))
-		(let ((loop-list (runs:expand-items hed tal reg reruns regfull newtal jobgroup max-concurrent-jobs run-id waitons item-path testmode test-record can-run-more items runname tconfig reglen test-registry test-records itemmaps)))
+		(let ((loop-list (runs:expand-items hed tal reg reruns regfull newtal jobgroup max-concurrent-jobs run-id waitons item-path testmode test-record can-run-more items runname tconfig reglen test-registry test-records itemmaps))) ;; itemized test expanded here
 		  (if loop-list
-		      (apply loop loop-list)))
+		      (apply loop loop-list)
+                      (debug:print-info 4 *default-log-port* " -- Can't expand hed="hed)
+                      )
+                  )
 		;; if can't run more just loop with next possible test
 		(loop (car newtal)(cdr newtal) reg reruns))))
-	    
+         
 	 ;; this case should not happen, added to help catch any bugs
 	 ((and (list? items) itemdat)
+          (debug:print-info 4 *default-log-port* "cond branch - "  "rtq-5")
 	  (debug:print-error 0 *default-log-port* "Should not have a list of items in a test and the itemspath set - please report this")
 	  (exit 1))
 	 ((not (null? reruns))
+          (debug:print-info 4 *default-log-port* "cond branch - "  "rtq-6")
 	  (let* ((newlst (tests:filter-non-runnable run-id tal test-records)) ;; i.e. not FAIL, WAIVED, INCOMPLETE, PASS, KILLED,
 		 (junked (lset-difference equal? tal newlst)))
 	    (debug:print-info 4 *default-log-port* "full drop through, if reruns is less than 100 we will force retry them, reruns=" reruns ", tal=" tal)
 	    (if (< num-retries max-retries)
 		(set! newlst (append reruns newlst)))
@@ -1368,20 +1597,24 @@
 	    ;; (thread-sleep! (+ 1 *global-delta*))
 	    (if (not (null? newlst))
 		;; since reruns have been tacked on to newlst create new reruns from junked
 		(loop (car newlst)(cdr newlst) reg (delete-duplicates junked)))))
 	 ((not (null? tal))
+          (debug:print-info 4 *default-log-port* "cond branch - "  "rtq-7")
 	  (debug:print-info 4 *default-log-port* "I'm pretty sure I shouldn't get here."))
 	 ((not (null? reg)) ;; could we get here with leftovers?
+          (debug:print-info 4 *default-log-port* "cond branch - "  "rtq-8")
 	  (debug:print-info 0 *default-log-port* "Have leftovers!")
 	  (loop (car reg)(cdr reg) '() reruns))
 	 (else
+          (debug:print-info 4 *default-log-port* "cond branch - "  "rtq-9")
 	  (debug:print-info 4 *default-log-port* "Exiting loop with...\n  hed=" hed "\n  tal=" tal "\n  reruns=" reruns))
-	 )))
+	 ))) ;; end loop on sorted test names
+    
     ;; now *if* -run-wait we wait for all tests to be done
     ;; Now wait for any RUNNING tests to complete (if in run-wait mode)
-    (thread-sleep! 5) ;; I think there is a race condition here. Let states/statuses settle
+    (thread-sleep! 10) ;; I think there is a race condition here. Let states/statuses settle
     (let wait-loop ((num-running      (rmt:get-count-tests-running-for-run-id run-id))
 		    (prev-num-running 0))
       ;; (debug:print-info 13 *default-log-port* "num-running=" num-running ", prev-num-running=" prev-num-running)
       (if (and (or (args:get-arg "-run-wait")
 		   (equal? (configf:lookup *configdat* "setup" "run-wait") "yes"))
@@ -1399,21 +1632,22 @@
 	    (thread-sleep! 5)
 	    ;; (wait-loop (rmt:get-count-tests-running-for-run-id run-id) num-running))))
 	    (wait-loop (rmt:get-count-tests-running-for-run-id run-id) num-running))))
     ;; LET* ((test-record
     ;; we get here on "drop through". All done!
+    (runs:run-post-hook run-id)
     (debug:print-info 1 *default-log-port* "All tests launched")))
 
 (define (runs:calc-fails prereqs-not-met)
   (filter (lambda (test)
 	    (and (vector? test) ;; not (string? test))
-		 (member (db:test-get-state test) '("INCOMPLETE" "COMPLETED"))
+		 (member (db:test-get-state test) '("INCOMPLETE" "COMPLETED")) ;; TODO: pull from *common:stuff...*
 		 (not (member (db:test-get-status test)
 			      '("PASS" "WARN" "CHECK" "WAIVED" "SKIP")))))
 	  prereqs-not-met))
 
-(define (runs:calc-prereq-fail prereqs-not-met)
+(define (runs:calc-prereq-fail prereqs-not-met) ;; REMOVEME since NOT_STARTED/PREQ_FAIL is now COMPLETED/PREQ_FAIL
   (filter (lambda (test)
 	    (and (vector? test) ;; not (string? test))
 		 (equal? (db:test-get-state test) "NOT_STARTED")
 		 (not (member (db:test-get-status test)
 			      '("n/a" "KEEP_TRYING")))))
@@ -1490,12 +1724,12 @@
     ;; per-test call is not needed. Given the delicacy of the move to 
     ;; v1.55 this code is being left in place for the time being.
     ;;
     (if (not (hash-table-ref/default *test-meta-updated* test-name #f))
         (begin
-	   (hash-table-set! *test-meta-updated* test-name #t)
-           (runs:update-test_meta test-name test-conf)))
+          (hash-table-set! *test-meta-updated* test-name #t)
+          (runs:update-test_meta test-name test-conf)))
     
     ;; itemdat => ((ripeness "overripe") (temperature "cool") (season "summer"))
     (let* ((new-test-path (string-intersperse (cons test-path (map cadr itemdat)) "/"))
 	   (test-id       (rmt:get-test-id run-id test-name item-path))
 	   (testdat       (if test-id (rmt:get-test-info-by-id run-id test-id) #f)))
@@ -1523,11 +1757,11 @@
 		  (thread-sleep! 1)
 		  (loop)))))
       (if (not testdat) ;; should NOT happen
 	  (debug:print-error 0 *default-log-port* "failed to get test record for test-id " test-id))
       (set! test-id (db:test-get-id testdat))
-      (if (file-exists? test-path)
+      (if (common:file-exists? test-path)
 	  (change-directory test-path)
 	  (begin
 	    (debug:print-error 0 *default-log-port* "test run path not created before attempting to run the test. Perhaps you are running -remove-runs at the same time?")
 	    (change-directory *toppath*)))
       (case (if force ;; (args:get-arg "-force")
@@ -1674,19 +1908,97 @@
      (+ 1 x))
    0 real-dir)
   ;; then the entire directory
   (runs:recursive-delete-with-error-msg real-dir))
 
+;; cleanup often needs to remove all but the last N runs per target
+;;
+;; target-patts a1/b1/c1,a2/b2/c2 ...
+;;
+;; This will fail if called with empty target or a bad target (i.e. missing or extra fields)
+;;
+(define (runs:get-hash-by-target target-patts runpatt)
+  (let* ((targets (string-split target-patts ","))
+	 (keys    (rmt:get-keys))
+	 (res-ht  (make-hash-table))) ;; target -> ( runrecord1 runrecord2 ... )
+    (for-each
+     (lambda (target-patt)
+       (let ((runs     (rmt:simple-get-runs runpatt #f #f target-patt)))
+	 (for-each
+	  (lambda (run)
+	    (let ((target (simple-run-target run)))
+	      (hash-table-set! res-ht target (cons run (hash-table-ref/default res-ht target '())))))
+	  runs)))
+     targets)
+    res-ht))
+
+;; delete runs older than X (weeks, days, months years etc.)
+;; delete redundant runs within a target - N is the input
+;; delete redundant runs within a target IFF older than given date/time AND keep at least N
+;; 
+(define (runs:remove-all-but-last-n-runs-per-target target-patts runpatt num-to-keep #!key (actions '(print)))
+  (let* ((runs-ht  (runs:get-hash-by-target target-patts runpatt))
+	 (age      (if (args:get-arg "-age")(common:hms-string->seconds (args:get-arg "-age")) #f))
+	 (age-mark (if age (- (current-seconds) age) (+ (current-seconds) 86400)))
+	 (precmd   (or (args:get-arg "-precmd") "")))
+    (print "Actions: " actions)
+    (for-each
+     (lambda (target)
+       (let* ((runs      (hash-table-ref runs-ht target))
+	      (sorted    (sort runs (lambda (a b)(< (simple-run-event_time a)(simple-run-event_time b)))))
+	      (to-remove (let* ((len      (length sorted))
+                                (trim-amt (- len num-to-keep)))
+                           (if (> trim-amt 0)
+                               (take sorted trim-amt)
+                               '()))))
+	 (hash-table-set! runs-ht target to-remove)
+         (print target ":")
+         (for-each
+          (lambda (run)
+            (let ((remove (member run to-remove (lambda (a b)
+                                                  (eq? (simple-run-id a)
+                                                       (simple-run-id b))))))
+	      (if (and age (> (simple-run-event_time run) age-mark))
+		  (print "Skipping handling of " target "/" (simple-run-runname run) " as it is younger than " (args:get-arg "-age"))
+		  (for-each
+		   (lambda (action)
+		     (case action
+		       ((print)
+			(print " " (simple-run-runname run)
+			       " " (time->string (seconds->local-time (simple-run-event_time run)) "WW%V.%u %H:%M:%S")
+			       " " (if remove "REMOVE" "")))
+		       ((remove-runs)
+			(if remove (system (conc precmd " megatest -remove-runs -target " target " -runname " (simple-run-runname run) " -testpatt %"))))
+		       ((archive)
+			(if remove (system (conc precmd " megatest -archive save-remove -target " target " -runname " (simple-run-runname run) " -testpatt %"))))))
+		   actions))))
+          sorted)))
+     ;; (print "Sorted: " (map simple-run-event_time sorted))
+     ;; (print "Remove: " (map simple-run-event_time to-remove))))
+     (hash-table-keys runs-ht))
+    runs-ht))
+
+;; (define (runs:remove-all-but-last-n-runs-per-target target-patts runpatt num-to-keep)
+;;   (let ((data (runs:get-all-but-most-recent-n-per-target target-patts runpatt num-to-keep)))
+;;     (for-each
+;;      (lambda (target)
+;;        (let ((runs-to-remove (hash-table-ref data target )))
+;;          (for-each
+;;           (lambda (run)
+;;             (print "megatest -remove-runs -target " target " -runname " (simple-run-runname run) " -testpatt %"))
+;;           runs-to-remove)))
+;;      (hash-table-keys data))))
+
 ;; Remove runs
 ;; fields are passing in through 
 ;; action:
 ;;    'remove-runs
 ;;    'set-state-status
 ;;
 ;; NB// should pass in keys?
 ;;
-(define (runs:operate-on action target runnamepatt testpatt #!key (state #f)(status #f)(new-state-status #f)(mode 'remove-all)(options '()))
+(define (runs:operate-on action target runnamepatt testpatt #!key (state #f)(status #f)(new-state-status #f)(mode #f)(options '()))
   (common:clear-caches) ;; clear all caches
   (let* ((db           #f)
 	 ;; (tdbdat       (tasks:open-db))
 	 (keys         (rmt:get-keys))
 	 (rundat       (mt:get-runs-by-patt keys runnamepatt target))
@@ -1694,20 +2006,20 @@
 	 (runs         (vector-ref rundat 1))
 	 (states       (if state  (string-split state  ",") '()))
 	 (statuses     (if status (string-split status ",") '()))
 	 (state-status (if (string? new-state-status) (string-split new-state-status ",") '(#f #f)))
 	 (rp-mutex     (make-mutex))
-	 (bup-mutex    (make-mutex)))
+	 (bup-mutex    (make-mutex))
+         (keep-records (args:get-arg "-keep-records"))) ;; used in conjunction with -remove-runs to keep the records, TODO: consolidate this with "mode".
 
     (let* ((write-access-actions '(remove-runs set-state-status archive run-wait))
            (dbfile             (conc  *toppath* "/megatest.db"))
            (readonly-mode      (not (file-write-access? dbfile))))
       (when (and readonly-mode
                  (member action write-access-actions))
         (debug:print-error 0 *default-log-port* "megatest.db is readonly.  Cannot proceed with action ["action"] in which write-access isrequired .")
         (exit 1)))
-
     
     (debug:print-info 4 *default-log-port* "runs:operate-on => Header: " header " action: " action " new-state-status: " new-state-status)
     (if (> 2 (length state-status))
 	(begin
 	  (debug:print-error 0 *default-log-port* "the parameter to -set-state-status is a comma delimited string. E.g. COMPLETED,FAIL")
@@ -1716,16 +2028,16 @@
      (lambda (run)
        (let ((runkey (string-intersperse (map (lambda (k)
 						(db:get-value-by-header run header k)) keys) "/"))
 	     (dirs-to-remove (make-hash-table))
 	     (proc-get-tests (lambda (run-id)
-			      (mt:get-tests-for-run run-id
-						    testpatt states statuses
-						    not-in:  #f
-						    sort-by: (case action
-							       ((remove-runs) 'rundir)
-							       (else          'event_time))))))
+                               (mt:get-tests-for-run run-id
+                                                     testpatt states statuses
+                                                     not-in:  #f
+                                                     sort-by: (case action
+                                                                ((remove-runs) 'rundir)
+                                                                (else          'event_time))))))
 	 (let* ((run-id    (db:get-value-by-header run header "id"))
 		(run-state (db:get-value-by-header run header "state"))
 		(run-name  (db:get-value-by-header run header "runname"))
 		(tests     (if (not (equal? run-state "locked"))
 			       (proc-get-tests run-id)
@@ -1777,10 +2089,13 @@
 								     (if (and (string? dira)(string? dirb))
 									 (> (string-length dira)(string-length dirb))
 									 #f))))))
 		       (toplevel-retries (make-hash-table)) ;; try three times to loop through and remove top level tests
 		       (test-retry-time  (make-hash-table))
+                       (backgrounded-remove-status     (make-hash-table))
+                       (backgrounded-remove-last-visit (make-hash-table))
+                       (backgrounded-remove-result     (make-hash-table))
 		       (allow-run-time   10)) ;; seconds to allow for killing tests before just brutally killing 'em
 		   (let loop ((test (car sorted-tests))
 			      (tal  (cdr sorted-tests)))
 		     (let* ((test-id       (db:test-get-id test))
 			    (new-test-dat  (rmt:get-test-info-by-id run-id test-id)))
@@ -1792,91 +2107,170 @@
 			   (let* ((item-path     (db:test-get-item-path new-test-dat))
 				  (test-name     (db:test-get-testname new-test-dat))
 				  (run-dir       ;;(filedb:get-path *fdb*
 				   ;; (rmt:sdb-qry 'getid 
 				   (db:test-get-rundir new-test-dat)) ;; )    ;; run dir is from the link tree
+                                  (has-subrun    (and (subrun:subrun-test-initialized? run-dir)
+                                                      (not (subrun:subrun-removed? run-dir))))
 				  (test-state    (db:test-get-state new-test-dat))
 				  (test-fulln    (db:test-get-fullname new-test-dat))
 				  (uname         (db:test-get-uname    new-test-dat))
 				  (toplevel-with-children (and (db:test-get-is-toplevel test)
 							       (> (rmt:test-toplevel-num-items run-id test-name) 0))))
 			     (case action
 			       ((remove-runs)
 				;; if the test is a toplevel-with-children issue an error and do not remove
-				(if toplevel-with-children
-				    (begin
-				      (debug:print 0 *default-log-port* "WARNING: skipping removal of " test-fulln " with run-id " run-id " as it has sub tests")
-				      (hash-table-set! toplevel-retries test-fulln (+ (hash-table-ref/default toplevel-retries test-fulln 0) 1))
-				      (if (> (hash-table-ref toplevel-retries test-fulln) 3)
-					  (if (not (null? tal))
-					      (loop (car tal)(cdr tal))) ;; no else clause - drop it if no more in queue and > 3 tries
-					  (let ((newtal (append tal (list test))))
-					    (loop (car newtal)(cdr newtal))))) ;; loop with test still in queue
-				    (begin
-				      (debug:print-info 0 *default-log-port* "test: " test-name " itest-state: " test-state)
-				      (if (member test-state (list "RUNNING" "LAUNCHED" "REMOTEHOSTSTART" "KILLREQ"))
-					  (begin
-					    (if (not (hash-table-ref/default test-retry-time test-fulln #f))
-						(begin
-						  ;; want to set to REMOVING BUT CANNOT do it here?
-						  (hash-table-set! test-retry-time test-fulln (current-seconds))))
-					    (if (> (- (current-seconds)(hash-table-ref test-retry-time test-fulln)) allow-run-time)
-						;; This test is not in a correct state for cleaning up. Let's try some graceful shutdown steps first
-						;; Set the test to "KILLREQ" and wait five seconds then try again. Repeat up to five times then give
-						;; up and blow it away.
-						(begin
-						  (debug:print 0 *default-log-port* "WARNING: could not gracefully remove test " test-fulln ", tried to kill it to no avail. Forcing state to FAILEDKILL and continuing")
-					    (mt:test-set-state-status-by-id run-id (db:test-get-id test) "FAILEDKILL" "n/a" #f)
-						  (thread-sleep! 1))
-						(begin
-					    (mt:test-set-state-status-by-id run-id (db:test-get-id test) "KILLREQ" "n/a" #f)
-						  (thread-sleep! 1)))
-					    ;; NOTE: This is suboptimal as the testdata will be used later and the state/status may have changed ...
-					    (if (null? tal)
-						(loop new-test-dat tal)
-						(loop (car tal)(append tal (list new-test-dat)))))
-					  (begin
-					    (runs:remove-test-directory new-test-dat mode) ;; 'remove-all)
-					    (if (not (null? tal))
-						(loop (car tal)(cdr tal)))))))
+				(cond
+                                 (toplevel-with-children
+                                  (debug:print 0 *default-log-port* "WARNING: skipping removal of " test-fulln " with run-id " run-id " as it has sub tests")
+                                  (hash-table-set! toplevel-retries test-fulln (+ (hash-table-ref/default toplevel-retries test-fulln 0) 1))
+                                  (if (> (hash-table-ref toplevel-retries test-fulln) 3)
+                                      (if (not (null? tal))
+                                          (loop (car tal)(cdr tal))) ;; no else clause - drop it if no more in queue and > 3 tries
+                                      (let ((newtal (append tal (list test))))
+                                        (loop (car newtal)(cdr newtal))))) ;; loop with test still in queue
+                                 (has-subrun
+                                  ;; 
+                                  (let ((last-visit (hash-table-ref/default backgrounded-remove-last-visit test-fulln 0))
+                                        (now        (current-seconds))
+                                        (rem-status (hash-table-ref/default backgrounded-remove-status test-fulln 'not-started)))
+                                    (case rem-status
+                                      ((not-started)
+                                       (debug:print 0 *default-log-port* "WARNING: postponing removal of " test-fulln " with run-id " run-id " as it has a subrun")
+                                       (hash-table-set! backgrounded-remove-status test-fulln 'started)
+                                       (hash-table-set! backgrounded-remove-last-visit test-fulln (current-seconds))
+                                       (common:send-thunk-to-background-thread
+                                        (lambda ()
+                                          (let* ((subrun-remove-succeeded
+                                                  (subrun:remove-subrun run-dir keep-records)))
+                                            (hash-table-set! backgrounded-remove-result test-fulln subrun-remove-succeeded)
+                                            (hash-table-set! backgrounded-remove-status test-fulln 'done)))
+                                        name: (conc "remove-subrun:"test-fulln))
+                                       
+                                       ;; send to back of line, loop
+                                       (let ((newtal (append tal (list test))))
+                                        (loop (car newtal)(cdr newtal)))
+                                       )
+                                      ((started)
+                                       ;; if last visit was within last second, sleep 1 second
+                                       (if (< (- now last-visit) 1.0)
+                                           (thread-sleep! 1.0))
+                                       (hash-table-set! backgrounded-remove-last-visit test-fulln (current-seconds))
+                                       ;; send to back of line, loop
+                                       (let ((newtal (append tal (list test))))
+                                        (loop (car newtal)(cdr newtal)))
+                                       )
+                                      ((done)
+                                       ;; drop this one; if remaining, loop, else finish
+                                       (hash-table-set! backgrounded-remove-last-visit test-fulln (current-seconds))
+                                       (let ((subrun-remove-succeeded (hash-table-ref/default backgrounded-remove-result test-fulln 'exception)))
+                                         (cond
+                                          ((eq? subrun-remove-succeeded 'exception)
+                                           (let* ((logfile (subrun:get-log-path run-dir "remove")))
+                                             (debug:print 0 *default-log-port* "ERROR: removing subrun of of " test-fulln " with run-id " run-id " ; see logfile @ "logfile)))
+                                          (subrun-remove-succeeded
+                                           (debug:print 0 *default-log-port* "Now removing of " test-fulln " with run-id " run-id " since subrun was removed.")
+                                           ;;(runs:remove-test-directory new-test-dat mode) ;; let normal case handle this. it will go thru loop again as non-subrun
+                                           )
+                                          (else
+                                           (let* ((logfile (subrun:get-log-path run-dir "remove")))
+                                             (debug:print 0 *default-log-port* "WARNING: removal of subrun failed.  Please check "logfile" for details."))))
+                                         ;;(if (not (null? tal))
+                                         ;;    (loop (car tal)(cdr tal)))
+                                         
+                                         ;; send to back of line, loop (will not match has-subrun next time through)
+                                       (let ((newtal (append tal (list test))))
+                                        (loop (car newtal)(cdr newtal)))
+                                         ))
+                                      ) ; end case rem-status
+                                    ) ; end let
+                                  ); end cond has-subrun
+
+                                 (else
+                                  ;; BB - TODO - consider backgrounding to threads to delete tests (work below) 
+                                  (debug:print-info 0 *default-log-port* "test: " test-name " itest-state: " test-state)
+                                  (if (member test-state (list "RUNNING" "LAUNCHED" "REMOTEHOSTSTART" "KILLREQ"))
+                                      (begin
+                                        (if (not (hash-table-ref/default test-retry-time test-fulln #f))
+                                            (begin
+                                              ;; want to set to REMOVING BUT CANNOT do it here?
+                                              (hash-table-set! test-retry-time test-fulln (current-seconds))))
+                                        (if (> (- (current-seconds)(hash-table-ref test-retry-time test-fulln)) allow-run-time)
+                                            ;; This test is not in a correct state for cleaning up. Let's try some graceful shutdown steps first
+                                            ;; Set the test to "KILLREQ" and wait five seconds then try again. Repeat up to five times then give
+                                            ;; up and blow it away.
+                                            (begin
+                                              (debug:print 0 *default-log-port* "WARNING: could not gracefully remove test " test-fulln ", tried to kill it to no avail. Forcing state to FAILEDKILL and continuing")
+                                              (mt:test-set-state-status-by-id run-id (db:test-get-id test) "FAILEDKILL" "n/a" #f)
+                                              (thread-sleep! 1))
+                                            (begin
+                                              (mt:test-set-state-status-by-id run-id (db:test-get-id test) "KILLREQ" "n/a" #f)
+                                              (thread-sleep! 1)))
+                                        ;; NOTE: This is suboptimal as the testdata will be used later and the state/status may have changed ...
+                                        (if (null? tal)
+                                            (loop new-test-dat tal)
+                                            (loop (car tal)(append tal (list new-test-dat)))))
+                                      (begin
+                                        (runs:remove-test-directory new-test-dat mode) ;; 'remove-all)
+                                        (if (not (null? tal))
+                                            (loop (car tal)(cdr tal)))))))
 				(rmt:update-run-stats run-id (rmt:get-raw-run-stats run-id)))
 			       ((set-state-status)
-				(debug:print-info 2 *default-log-port* "new state " (car state-status) ", new status " (cadr state-status))
-				(mt:test-set-state-status-by-id run-id (db:test-get-id test) (car state-status)(cadr state-status) #f)
+                                (let* ((new-state (car state-status))
+                                       (new-status (cadr state-status))
+                                       (test-id (db:test-get-id test))
+                                       (test-run-dir (db:test-get-rundir new-test-dat))
+                                       (has-subrun (and (subrun:subrun-test-initialized? test-run-dir)
+                                                      (not (subrun:subrun-removed? test-run-dir)))))
+                                  (when has-subrun
+                                     (common:send-thunk-to-background-thread
+                                        (lambda ()
+                                          (subrun:set-state-status test-run-dir state status new-state-status)
+                                          )
+                                        )
+                                    )
+                                  (debug:print-info 2 *default-log-port* "new state " new-state ", new status " new-status )
+                                  (mt:test-set-state-status-by-id run-id test-id new-state new-status #f))
 				(if (not (null? tal))
 				    (loop (car tal)(cdr tal))))
 			       ((run-wait)
+                                ;; BB TODO - manage has-subrun case
 				(debug:print-info 2 *default-log-port* "still waiting, " (length tests) " tests still running")
 				(thread-sleep! 10)
 				(let ((new-tests (proc-get-tests run-id)))
 				  (if (null? new-tests)
 				      (debug:print-info 1 *default-log-port* "Run completed according to zero tests matching provided criteria.")
 				      (loop (car new-tests)(cdr new-tests)))))
 			       ((archive)
+                                ;; BB TODO - manage has-subrun case
 				(if (and run-dir (not toplevel-with-children))
 				    (let ((ddir (conc run-dir "/")))
 				      (case (string->symbol (args:get-arg "-archive"))
 					((save save-remove keep-html)
-					 (if (file-exists? ddir)
+					 (if (common:file-exists? ddir)
 					     (debug:print-info 0 *default-log-port* "Estimating disk space usage for " test-fulln ": " (common:get-disk-space-used ddir)))))))
 				(if (not (null? tal))
 				    (loop (car tal)(cdr tal))))
 			       )))
 		       )
-		     (if worker-thread (thread-join! worker-thread))))))
+		     (if worker-thread (thread-join! worker-thread)))
+                   (common:join-backgrounded-threads))))
 	   ;; remove the run if zero tests remain
 	   (if (eq? action 'remove-runs)
-	       (let ((remtests (mt:get-tests-for-run (db:get-value-by-header run header "id") #f '("DELETED") '("n/a") not-in: #t)))
+	       (let* ((run-id   (db:get-value-by-header run header "id")) ;; NB// masks run-id from above?
+                      (remtests (mt:get-tests-for-run run-id #f '("DELETED") '("n/a") not-in: #t)))
 		 (if (null? remtests) ;; no more tests remaining
 		     (let* ((dparts  (string-split lasttpath "/"))
 			    (runpath (conc "/" (string-intersperse 
 						(take dparts (- (length dparts) 1))
 						"/"))))
 		       (debug:print 1 *default-log-port* "Removing run: " runkey " " (db:get-value-by-header run header "runname") " and related record")
-		       (rmt:delete-run run-id)
-		       (rmt:delete-old-deleted-test-records)
-		       ;; (rmt:set-var "DELETED_TESTS" (current-seconds))
+                       (if (not keep-records)
+                           (begin
+                             (rmt:delete-run run-id)
+                             (rmt:delete-old-deleted-test-records)))
+                           ;; (rmt:set-var "DELETED_TESTS" (current-seconds))
 		       ;; need to figure out the path to the run dir and remove it if empty
 		       ;;    (if (null? (glob (conc runpath "/*")))
 		       ;;        (begin
 		       ;; 	 (debug:print 1 *default-log-port* "Removing run dir " runpath)
 		       ;; 	 (system (conc "rmdir -p " runpath))))
@@ -1887,25 +2281,41 @@
     )
   #t)
 
 (define (runs:remove-test-directory test mode) ;; remove-data-only)
   (let* ((run-dir       (db:test-get-rundir test))    ;; run dir is from the link tree
-	 (real-dir      (if (file-exists? run-dir)
+	 (real-dir      (if (common:file-exists? run-dir)
 			    ;; (resolve-pathname run-dir)
 			    (common:nice-path run-dir)
-			    #f)))
-    (case mode
+			    #f))
+         (clean-mode    (or mode 'remove-all))
+         (test-id       (db:test-get-id test))
+        ;; (lock-key      (conc "test-" test-id))
+        ;; (got-lock      (let loop ((lock        (rmt:no-sync-get-lock lock-key))
+	;; 			     (expire-time (+ (current-seconds) 30))) ;; give up on getting the lock and steal it after 15 seconds
+	;; 		    (if (car lock)
+	;; 			#t
+	;; 			(if (> (current-seconds) expire-time)
+	;; 			    (begin
+	;; 			      (debug:print-info 0 *default-log-port* "Timed out waiting for a lock to clean test with id " test-id)
+	;; 			      (rmt:no-sync-del! lock-key) ;; destroy the lock
+	;; 			      (loop (rmt:no-sync-get-lock lock-key) expire-time)) ;; 
+	;; 			    (begin
+	;; 			      (thread-sleep! 1)
+	 ;; 			      (loop (rmt:no-sync-get-lock lock-key) expire-time)))))))
+	 )
+    (case clean-mode
       ((remove-data-only)(mt:test-set-state-status-by-id (db:test-get-run_id test)(db:test-get-id test) "CLEANING" "LOCKED" #f))
       ((remove-all)      (mt:test-set-state-status-by-id (db:test-get-run_id test)(db:test-get-id test) "REMOVING" "LOCKED" #f))
       ((archive-remove)  (mt:test-set-state-status-by-id (db:test-get-run_id test)(db:test-get-id test) "ARCHIVE_REMOVING" #f #f)))
     (debug:print-info 1 *default-log-port* "Attempting to remove " (if real-dir (conc " dir " real-dir " and ") "") " link " run-dir)
     (if (and real-dir 
 	     (> (string-length real-dir) 5)
-	     (file-exists? real-dir)) ;; bad heuristic but should prevent /tmp /home etc.
+	     (common:file-exists? real-dir)) ;; bad heuristic but should prevent /tmp /home etc.
 	(begin ;; let* ((realpath (resolve-pathname run-dir)))
 	  (debug:print-info 1 *default-log-port* "Recursively removing " real-dir)
-	  (if (file-exists? real-dir)
+	  (if (common:file-exists? real-dir)
 	      (runs:safe-delete-test-dir real-dir)
 	      (debug:print 0 *default-log-port* "WARNING: test dir " real-dir " appears to not exist or is not readable")))
 	(if real-dir 
 	    (debug:print 0 *default-log-port* "WARNING: directory " real-dir " does not exist")
 	    (debug:print 0 *default-log-port* "WARNING: no real directory corrosponding to link " run-dir ", nothing done")))
@@ -1927,14 +2337,16 @@
 		     (not (member run-dir (list "n/a" "/tmp/badname"))))
 		(debug:print 0 *default-log-port* "WARNING: not removing " run-dir " as it either doesn't exist or is not a symlink")
 		(debug:print 0 *default-log-port* "NOTE: the run dir for this test is undefined. Test may have already been deleted."))
 	    ))
     ;; Only delete the records *after* removing the directory. If things fail we have a record 
-    (case mode
-      ((remove-data-only)(mt:test-set-state-status-by-id (db:test-get-run_id test)(db:test-get-id test) "NOT_STARTED" "n/a" #f))
+    (case clean-mode
+      ((remove-data-only)(mt:test-set-state-status-by-id (db:test-get-run_id test)(db:test-get-id test) (db:test-get-state test)(db:test-get-status test) #f))
       ((archive-remove)  (mt:test-set-state-status-by-id (db:test-get-run_id test)(db:test-get-id test) "ARCHIVED" #f #f))
-      (else (rmt:delete-test-records (db:test-get-run_id test) (db:test-get-id test))))))
+      (else (rmt:delete-test-records (db:test-get-run_id test) (db:test-get-id test))))
+    ;; (rmt:no-sync-del! lock-key)
+    ))
 
 ;;======================================================================
 ;; Routines for manipulating runs
 ;;======================================================================
 
@@ -1954,11 +2366,12 @@
       (let (;; (db   #f)
 	    (keys #f))
 	(if (launch:setup)
 	    (begin
 	      (full-runconfigs-read) ;; cache the run config
-	      (launch:cache-config)) ;; do not cache here - need to be sure runconfigs is processed
+	      ;; (launch:cache-config) ;; there are two independent config cache locations, turning this one off for now. MRW.
+	      ) ;; do not cache here - need to be sure runconfigs is processed
 	    (begin 
 	      (debug:print 0 *default-log-port* "Failed to setup, exiting")
 	      (exit 1)))
 
         
@@ -2115,11 +2528,11 @@
 (define (runs:clean-cache target runname toppath)
   (if target
       (if runname
 	  (let* ((linktree (common:get-linktree)) ;; (if toppath (configf:lookup *configdat* "setup" "linktree")))
 		 (runtop   (conc linktree "/" target "/" runname))
-		 (files    (if (file-exists? runtop)
+		 (files    (if (common:file-exists? runtop)
 			       (append (glob (conc runtop "/.megatest*"))
 				       (glob (conc runtop "/.runconfig*")))
 			       '())))
 	    (if (null? files)
 		(debug:print-info 0 *default-log-port* "No cached megatest or runconfigs files found. None removed.")

ADDED   sample-sauth-paths.scm
Index: sample-sauth-paths.scm
==================================================================
--- /dev/null
+++ sample-sauth-paths.scm
@@ -0,0 +1,20 @@
+;; 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 *db-path* "/path/to/db") 
+(define *exe-path* "/path/to/store/suids")  
+(define *exe-src* "/path/to/spublish/and/sretrieve/executables")
+(define *sauth-path* "/path/to/production/sauthorize/exe")
+(define *super-users* '("user1" "user2"))

ADDED   sauth-common.scm
Index: sauth-common.scm
==================================================================
--- /dev/null
+++ sauth-common.scm
@@ -0,0 +1,302 @@
+
+;; Create the sqlite db
+(define (sauthorize:db-do proc) 
+      (if (or (not *db-path*)
+              (not (file-exists? *db-path*))) 
+	(begin
+	  (print 0 "[database]\nlocation " *db-path* " \n\n Is missing from the config file!")
+	  (exit 1)))
+    (if (and *db-path*
+	     (directory? *db-path*)
+	     (file-read-access? *db-path*))
+	(let* ((dbpath    (conc *db-path* "/sauthorize.db"))
+	       (writeable (file-write-access? dbpath))
+	       (dbexists  (file-exists? dbpath)))
+	  (handle-exceptions
+	   exn
+	   (begin
+	     (debug:print 2 "ERROR: problem accessing db " dbpath
+			  ((condition-property-accessor 'exn 'message) exn))
+	     (exit 1))
+            ;(print  "calling proc " proc "db path " dbpath )
+	   (call-with-database
+            dbpath
+	    (lambda (db)
+	       ;(print 0 "calling proc " proc " on db " db)
+	      (set-busy-handler! db (busy-timeout 10000)) ;; 10 sec timeout
+	      (if (not dbexists)(sauthorize:initialize-db db))
+	      (proc db)))))
+	(print 0 "ERROR: invalid path for storing database: " *db-path*)))
+
+;;execute a query
+(define (sauthorize:db-qry db qry)
+  ;(print qry)
+  (exec (sql db  qry)))
+
+
+(define (sauthorize:do-as-calling-user proc)
+  (let ((eid (current-effective-user-id))
+        (cid (current-user-id)))
+    (if (not (eq? eid cid)) ;; running suid
+            (set! (current-effective-user-id) cid))
+     ;(print 0 "cid " cid " eid:" eid)
+    (proc)
+    (if (not (eq? eid cid))
+        (set! (current-effective-user-id) eid))))
+
+
+(define (run-cmd cmd arg-list)
+  ; (print (current-effective-user-id))
+   ;(handle-exceptions
+;	     exn
+;	     (print 0 "ERROR: failed to run script " cmd " with params " arg-list " " (exn assert))
+	     (let ((pid (process-run cmd arg-list)))
+	       (process-wait pid))
+)
+;)
+
+
+(define (regster-log inl usr-id  area-id  cmd)
+  (sauth-common:shell-do-as-adm
+        (lambda ()
+         (sauthorize:db-do   (lambda (db)
+             (sauthorize:db-qry db (conc "INSERT INTO actions (cmd,user_id,area_id,action_type ) VALUES ('sretrieve " inl "'," usr-id ","  area-id ", 'cat' )")))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+; Check user types
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+
+
+;;check if a user is an admin
+(define (is-admin username)
+   (let* ((admin #f))
+    (sauthorize:db-do  (lambda (db)
+        (let* ((data-row (query fetch (sql db (conc "SELECT users.is_admin FROM  users where users.username = '" username "'")))))
+        (if (not (null? data-row))
+             (let ((col  (car data-row)))
+             (if (equal? col "yes")
+                   (set! admin #t)))))))  	        
+admin))
+
+
+;;check if a user is an read-admin
+(define (is-read-admin username)
+   (let* ((admin #f))
+    (sauthorize:db-do  (lambda (db)
+        (let* ((data-row (query fetch (sql db (conc "SELECT users.is_admin FROM  users where users.username = '" username "'")))))
+        (if (not (null? data-row))
+             (let ((col  (car data-row)))
+             (if (equal? col "read-admin")
+                   (set! admin #t)))))))  	        
+admin))
+
+
+;;check if user has specifc role for a area
+(define (is-user role username area)
+  (let* ((has-access #f))
+    (sauthorize:db-do  (lambda (db)
+        (let* ((data-row (query fetch (sql db (conc "SELECT  permissions.access_type, permissions.expiration FROM  users ,  areas, permissions where permissions.user_id = users.id and permissions.area_id = areas.id and users.username = '" username "' and areas.code = '" area "'")))))
+        (if (not (null? data-row))
+           (begin
+               (let* ((access-type  (car data-row))
+                    (exdate (cadr data-row)))
+               (if (not (null? exdate)) 
+               (begin 
+                  (let ((valid (is-access-valid  exdate)))
+                   ;(print valid) 
+                  (if (and (equal? access-type role)
+                        (equal? valid #t))
+                   (set! has-access #t))))
+                (print "Access expired"))))))))
+ ;(print has-access)
+has-access))
+
+(define (is-access-valid exp-str)
+    (let* ((ret-val #f )
+           (date-parts  (string-split exp-str "/"))
+           (yr (string->number (car date-parts)))
+           (month (string->number(car (cdr date-parts)))) 
+           (day (string->number(caddr date-parts)))
+           (exp-date (make-date 0 0 0 0 day month yr )))
+             ;(print  exp-date)
+             ;(print (current-date))   
+            (if (> (date-compare exp-date  (current-date)) 0)
+             (set! ret-val #t))
+   ;(print ret-val)
+   ret-val))
+
+
+;check if area exists
+(define (area-exists area)
+   (let* ((area-defined #f))
+    (sauthorize:db-do  (lambda (db)
+        (let* ((data-row (query fetch (sql db (conc "SELECT  id FROM  areas where areas.code = '" area "'")))))
+           (if (not (null? data-row))
+                 (set! area-defined #t)))))
+area-defined))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+; Get Record from database
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;gets area id by code 
+(define (get-area area)
+   (let* ((area-defined '()))
+    (sauthorize:db-do  (lambda (db)
+        (let* ((data-row (query fetch (sql db (conc "SELECT  id FROM  areas where areas.code = '" area "'")))))
+          (set!  area-defined data-row))))
+area-defined))
+
+;get id of users table by user name 
+(define (get-user user)
+  (let* ((user-defined '()))
+    (sauthorize:db-do  (lambda (db)
+        (let* ((data-row (query fetch (sql db (conc "SELECT  id FROM  users where users.username = '" user "'")))))
+          (set!  user-defined data-row))))
+user-defined))
+
+;get permissions id by userid and area id 
+(define (get-perm userid areaid)
+  (let* ((user-defined '()))
+    (sauthorize:db-do  (lambda (db)
+          (let* ((data-row (query fetch (sql db (conc "SELECT  id FROM  permissions where user_id = " userid " and area_id = " areaid)))))
+         (set!  user-defined data-row))))
+
+user-defined))
+
+(define (get-restrictions base-path usr)
+(let* ((user-defined '()))
+    (sauthorize:db-do  (lambda (db)
+          (let* ((data-row (query fetch (sql db (conc "SELECT  restriction FROM areas, users, permissions where  areas.id = permissions.area_id and users.id =  permissions.user_id and  users.username = '" usr "' and areas.basepath = '" base-path "'")))))
+         ;(print data-row) 
+         (set!  user-defined data-row))))
+    ;   (print user-defined)
+  (if (null? user-defined)
+      ""
+      (car user-defined))))
+
+
+(define (get-obj-by-path path)
+   (let* ((obj '()))
+    (sauthorize:db-do  (lambda (db)
+        (let* ((data-row (query fetch (sql db (conc "SELECT  code,exe_name, id, basepath FROM  areas where areas.basepath = '" path "'")))))
+         (set!  obj data-row))))
+obj))
+
+(define (get-obj-by-code code )
+  (let* ((obj '()))
+    (sauthorize:db-do  (lambda (db)
+        ;(print (conc "SELECT  code, exe_name,  id, basepath, required_grps  FROM  areas where areas.code = '" code "'"))
+        (let* ((data-row (query fetch (sql db (conc "SELECT  code, exe_name,  id, basepath, required_grps  FROM  areas where areas.code = '" code "'")))))
+         ;(print data-row)
+         (set!  obj data-row)
+         ;(print obj) 
+        )))
+    (if (not (null? obj))
+          (begin
+          (let* ((req-grp (caddr (cddr obj))))
+            (sauthorize:do-as-calling-user
+             (lambda ()
+ (sauth-common:check-user-groups req-grp))))))
+obj))
+
+(define (sauth-common:check-user-groups req-grp)
+(let* ((current-groups  (get-groups) )
+        (req-grp-list (string-split req-grp ",")))
+        ;(print req-grp-list)
+        (for-each (lambda (grp)
+	  (let ((grp-info (group-information grp)))
+               ;(print grp-info " " grp)
+               (if (not (equal? grp-info #f))
+               (begin
+                 (if (not (member  (caddr grp-info) current-groups))
+                  (begin 
+                    (sauth:print-error (conc "Please wash " grp " group in your xterm!! " ))
+                     (exit 1)))))))
+	     req-grp-list)))
+
+(define (get-obj-by-code-no-grp-validation code )
+  (let* ((obj '()))
+    (sauthorize:db-do  (lambda (db)
+        (let* ((data-row (query fetch (sql db (conc "SELECT  code, exe_name,  id, basepath  FROM  areas where areas.code = '" code "'")))))
+         (set!  obj data-row))))
+;(print obj)
+obj))
+
+
+
+
+;; function to validate the users input for target path and resolve the path
+;; TODO: Check for restriction in subpath 
+(define (sauth-common:resolve-path  new current allowed-sheets)
+   (let* ((target-path (append  current (string-split new "/")))
+          (target-path-string (string-join target-path "/"))
+          (normal-path (normalize-pathname target-path-string))
+          (normal-list (string-split normal-path "/"))
+           (ret '()))
+   (if (string-contains   normal-path "..")
+    (begin
+      (print "ERROR: Path  " new " resolved outside target area ")
+      #f)
+    (if(equal? normal-path ".")
+      ret  
+    (if (not (member  (car normal-list) allowed-sheets))
+      (begin
+      (print "ERROR: Permision denied to  " new )
+       #f)
+    normal-list)))))
+
+(define (sauth-common:get-target-path base-path-list ext-path top-areas base-path)
+  (let* ((resolved-path (sauth-common:resolve-path ext-path base-path-list top-areas ))
+          (usr (current-user-name) ) )
+          (if (not (equal? resolved-path #f))
+           (if (null? resolved-path) 
+             #f
+           (let* ((sheet (car resolved-path))
+                   (restricted-areas (get-restrictions base-path usr))
+                   (restrictions (conc ".*" (string-join (string-split restricted-areas ",") ".*|.*") ".*"))
+           	   (target-path (if (null? (cdr resolved-path)) 
+                                     base-path 
+                                     (conc base-path "/" (string-join (cdr resolved-path) "/")))))
+                    
+	              
+                           (if (and (not (equal? restricted-areas "" ))
+                             (string-match (regexp  restrictions) target-path)) 
+                           (begin
+                              (sauth:print-error "Access denied to " (string-join resolved-path "/"))
+                              ;(exit 1)   
+                            #f)
+                             target-path)
+                            
+))
+             #f)))
+
+(define (sauth-common:shell-ls-cmd base-path-list ext-path top-areas base-path tail-cmd-list)
+    (if (and (null? base-path-list) (equal? ext-path "") )
+      (print (string-intersperse top-areas " "))
+  (let* ((resolved-path (sauth-common:resolve-path ext-path base-path-list top-areas )))
+           ;(print resolved-path)
+           (if (not (equal? resolved-path #f))
+           (if (null? resolved-path) 
+             (print (string-intersperse top-areas " "))
+           (let* ((target-path (sauth-common:get-target-path  base-path-list  ext-path top-areas base-path)))
+                (print target-path)
+                (if (not (equal? target-path #f))
+                (begin 
+                (cond
+		  ((null? tail-cmd-list)
+		     (run (pipe
+      	      	      (ls "-lrt" ,target-path))))
+		  ((not (equal? (car tail-cmd-list) "|"))
+                         (print "ls cmd cannot accept " (string-join tail-cmd-list) " as an argument!!"))
+                  (else  
+                    (run (pipe
+      	      	      (ls "-lrt" ,target-path)
+                      (begin (system (string-join (cdr tail-cmd-list))))))))))))))))
+
+(define (sauth:print-error msg)
+  (with-output-to-port (current-error-port)
+	(lambda ()
+	       (print (conc "ERROR: " msg)))))
+

ADDED   sauthorize.scm
Index: sauthorize.scm
==================================================================
--- /dev/null
+++ sauthorize.scm
@@ -0,0 +1,652 @@
+
+;; Copyright 2006-2013, 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 defstruct)
+(use scsh-process)
+
+(use srfi-18)
+(use srfi-19)
+(use refdb)
+
+(use sql-de-lite srfi-1 posix regex regex-case srfi-69)
+(declare (uses common))
+
+(declare (uses configf))
+(declare (uses margs))
+(declare (uses megatest-version))
+
+(include "megatest-fossil-hash.scm")
+;;; please create this file before using sautherise. For sample file is avaliable sample-sauth-paths.scm. 
+(include "sauth-paths.scm")
+(include "sauth-common.scm")
+
+;;
+;; GLOBALS
+;;
+(define *verbosity* 1)
+(define *logging* #f)
+(define *exe-name* (pathname-file (car (argv))))
+(define *sretrieve:current-tab-number* 0)
+(define *args-hash* (make-hash-table))
+(define sauthorize:help (conc "Usage: " *exe-name* " [action [params ...]]
+
+  list                   		 			: list areas $USER's can access
+  log                    		 			: get listing of recent activity.
+  sauth  list-area-user  			: list the users that can access the area.
+  sauth open  --group                       : Open up an area. User needs to be the owner of the area to open it. 
+              --code  
+              --retrieve|--publish [--additional-grps ]
+  sauth update   --retrieve|--publish             : update the binaries with the lates changes
+  sauth grant  --area           : Grant permission to read or write to a area that is alrady opend up.    
+             --expiration yyyy/mm/dd --retrieve|--publish 
+             [--restrict  ]  
+  sauth read-shell                        :  Open sretrieve shell for reading.  
+  sauth write-shell                       :  Open spublish shell for writing.
+   
+Part of the Megatest tool suite.
+Learn more at http://www.kiatoa.com/fossils/megatest
+
+Version: " megatest-fossil-hash)) ;; "
+
+;;======================================================================
+;; RECORDS
+;;======================================================================
+
+;;======================================================================
+;; DB
+;;======================================================================
+
+;; replace (strftime('%s','now')), with datetime('now'))
+(define (sauthorize:initialize-db db)
+  (for-each
+   (lambda (qry)
+     (exec (sql db qry)))
+   (list 
+    "CREATE TABLE IF NOT EXISTS actions
+         (id           INTEGER PRIMARY KEY,
+          cmd       TEXT NOT NULL,
+          user_id      INTEGER NOT NULL,
+          datetime     TIMESTAMP DEFAULT (datetime('now','localtime')),
+          area_id      INTEGER NOT NULL,
+          comment      TEXT DEFAULT '' NOT NULL,
+          action_type  TEXT NOT NULL);"
+        "CREATE TABLE IF NOT EXISTS users
+         (id           INTEGER PRIMARY KEY,
+          username     TEXT NOT NULL,
+          is_admin     TEXT NOT NULL,
+          datetime     TIMESTAMP DEFAULT (datetime('now','localtime'))
+          );" 
+          "CREATE TABLE IF NOT EXISTS areas
+         (id           INTEGER PRIMARY KEY,
+          basepath     TEXT NOT NULL,
+          code         TEXT NOT NULL,
+          exe_name     TEXT NOT NULL,
+          required_grps TEXT DEFAULT '' NOT NULL,
+          datetime     TIMESTAMP DEFAULT (datetime('now','localtime'))
+          );" 
+         "CREATE TABLE IF NOT EXISTS permissions
+         (id              INTEGER PRIMARY KEY,
+          access_type     TEXT NOT NULL,
+          user_id         INTEGER NOT NULL,
+          datetime        TIMESTAMP DEFAULT (datetime('now','localtime')),
+          area_id         INTEGER NOT NULL,
+          restriction     TEXT DEFAULT '' NOT NULL,
+          expiration       TIMESTAMP DEFAULT NULL);"
+    )))
+
+
+
+
+(define (get-access-type args)
+   (let loop ((hed (car args))
+		 (tal (cdr args)))
+                   (cond
+                   ((equal? hed "--retrieve")
+                      "retrieve") 
+                   ((equal? hed "--publish")
+                      "publish") 
+                   ((equal? hed "--area-admin")
+                      "area-admin")
+                   ((equal? hed "--writer-admin")
+                      "writer-admin")
+                   ((equal? hed "--read-admin")
+                      "read-admin")
+
+                   ((null? tal)
+                      #f) 
+                   (else 
+		  	(loop (car tal)(cdr tal))))))
+
+
+
+;; check if user can gran access to an area
+(define (can-grant-perm username access-type area)
+   (let* ((isadmin (is-admin username))
+          (is-area-admin (is-user "area-admin" username area ))
+          (is-read-admin (is-user "read-admin" username area) )
+          (is-writer-admin (is-user "writer-admin" username area) ) )
+   (cond
+   ((equal? isadmin  #t)
+     #t)
+   ((equal? is-area-admin #t ) 
+     #t)
+   ((and (equal? is-writer-admin #t ) (equal? access-type "retrieve"))
+     #t)
+   ((and (equal? is-read-admin #t ) (equal? access-type "retrieve"))
+     #t)
+
+   (else  
+    #f))))
+
+(define (sauthorize:list-areausers  area )
+  (sauthorize:db-do  (lambda (db)
+				     (print "Users having access to " area ":")
+				     (query (for-each-row
+					     (lambda (row)
+                                               (let* ((exp-date (cadr row)))
+                                                (if  (is-access-valid  exp-date)   
+					        (apply print (intersperse row " | "))))))
+					    (sql db (conc "SELECT users.username, permissions.expiration, permissions.access_type  FROM users, areas, permissions where permissions.user_id = users.id and permissions.area_id = areas.id and areas.code = '" area "'"))))))
+
+
+
+
+; check if executable exists
+(define (exe-exist exe access-type)
+    (let* ((filepath (conc *exe-path* "/" access-type "/" exe)))
+    ; (print filepath)
+     (if (file-exists? filepath)
+       #t
+       #f)))
+
+(define (copy-exe access-type exe-name group)
+  (run-cmd "/bin/chmod" (list "g+w" (conc *exe-path* "/" access-type)))
+  (let* ((spath (conc *exe-src*  "/s" access-type))
+         (dpath (conc *exe-path* "/" access-type "/" exe-name)))
+         (sauthorize:do-as-calling-user
+        (lambda ()
+            (run-cmd "/bin/cp" (list spath dpath )) 
+            (if (equal? access-type "publish")
+              (run-cmd "/bin/chmod" (list "u+s,o+rx" dpath))
+              (begin
+               (if (equal? group "none")
+                 (run-cmd "/bin/chmod" (list "u+s,o+rx" dpath))
+                 (begin   
+                     (run-cmd "/bin/chgrp" (list group dpath))
+                       (run-cmd "/bin/chmod" (list "g+s,o+rx" dpath))))))))
+	(run-cmd "chmod" (list "g-w" (conc *exe-path* "/" access-type)))))
+
+(define (get-exe-name path group)
+   (let ((name ""))
+   (sauthorize:do-as-calling-user
+        (lambda ()
+        (if (equal? (current-effective-user-id) (file-owner path)) 
+          (set! name (conc (current-user-name) "_" group))
+          (begin
+            (print "You cannot open areas that you dont own!!")  
+             (exit 1)))))
+name))
+
+(define (sauthorize:valid-unix-user username)
+    (let* ((ret-val #f))
+    (let-values (((inp oup pid)
+              (process "/usr/bin/id" (list username))))
+        (let loop ((inl (read-line inp)))
+          (if (string? inl) 
+          (if (string-contains inl  "No such user") 
+            (set! ret-val #f)
+             (set! ret-val #t)))   
+          (if (eof-object? inl)
+              (begin
+                   (close-input-port inp)
+                  (close-output-port oup))
+            (loop (read-line inp)))))
+            ret-val))
+
+
+;check if a paths/codes are vaid and if area is alrady open  
+(define (open-area group path code access-type other-grps)
+   (let* ((exe-name (get-exe-name path group))
+           (path-obj (get-obj-by-path path))
+           (code-obj (get-obj-by-code-no-grp-validation code)))
+           ;(print path-obj)   
+          (cond
+            ((not (null? path-obj))
+                (if (equal? code (car path-obj))
+                  (begin
+                     (if (equal? exe-name (cadr path-obj))
+                        (begin
+                            (if (not (exe-exist exe-name  access-type))
+                                 (copy-exe access-type exe-name group)
+                                 (begin 
+                                  (print "Area already open!!")
+                                  (exit 1))))   
+			(begin
+                           (if (not (exe-exist exe-name  access-type))
+                                 (copy-exe access-type exe-name group))
+                           ;; update exe-name  in db 
+                      (sauthorize:db-do   (lambda (db)
+                         (sauthorize:db-qry db (conc "update areas set exe_name = '" exe-name "' where id = " (caddr path-obj)))))
+                        )))
+                   (begin
+                       (print "Path " path " is registered with --code " (car path-obj) ". To open this area please execute following cmd: \n  sauthorize open " path " --group " group " --code " (car path-obj) " --" access-type )
+                       (exit 1))))
+                      
+            ((not (null? code-obj))
+                   (print "Code " code " is used for diffrent path. Please try diffrent value of --code" ) 
+                   (exit 1))
+            (else
+               ; (print (exe-exist exe-name  access-type))
+                (if (not (exe-exist exe-name  access-type))
+                        (copy-exe access-type exe-name group))
+                (sauthorize:db-do   (lambda (db)
+               (print conc "insert into areas (code, basepath, exe_name, required_grps) values ('" code "', '" path "', '" exe-name "', '" other-grps "') ") 
+             (sauthorize:db-qry db (conc "insert into areas (code, basepath, exe_name, required_grps) values ('" code "', '" path "', '" exe-name "', '" other-grps "') "))))))))
+
+(define (user-has-open-perm user path access)
+  (let* ((has-access #f)
+         (eid (current-user-id)))
+    (cond
+     ((is-admin  user)
+       (set! has-access #t ))
+     ((and (is-read-admin  user) (equal? access "retrieve"))
+       (set! has-access #t ))
+     (else
+        (print "User " user " does not have permission to open areas")))
+        has-access))
+
+
+;;check if user has group access
+(define (is-group-washed req_grpid current-grp-list)
+  (let loop ((hed (car current-grp-list))
+		 (tal (cdr current-grp-list)))
+                   (cond
+                   ((equal? hed req_grpid)
+                    #t)    
+                   ((null? tal)
+                      #f)
+                   (else 
+		  	(loop (car tal)(cdr tal))))))
+
+;create executables with appropriate suids
+(define (sauthorize:open user path group code access-type other-groups)
+   (let* ((gpid (group-information group))
+         (req_grpid (if (equal? group "none")
+                      group 
+                      (if (equal? gpid #f)
+                           #f      
+                     (caddr gpid))))
+         (current-grp-list (get-groups))
+         (valid-grp (if (equal? group "none")
+                     group
+                    (is-group-washed req_grpid current-grp-list))))
+   (if (and (not (equal? group "none")) (equal? valid-grp #f ))
+       (begin
+       (print "Group " group " is not washed in the current xterm!!") 
+       (exit 1)))) 
+   (if (not (file-write-access? path))
+     (begin
+       (print "You can open areas owned by yourself. You do not have permissions to open path." path)
+        (exit 1)))
+   (if (user-has-open-perm user path access-type)
+      (begin 
+       ;(print "here")   
+       (open-area group path code access-type other-groups)
+       (sauthorize:grant user user code "2017/12/25"  "read-admin" "") 
+       (sauthorize:db-do   (lambda (db)
+             (sauthorize:db-qry db (conc "INSERT INTO actions (cmd,user_id,area_id,action_type ) VALUES ('sauthorize open " path " --code " code " --group " group " --" access-type "'," (car (get-user user)) "," (car (get-area code)) ", 'open' )"))))
+         (print "Area has " path "  been opened for " access-type ))))
+
+(define (sauthorize:update username exe area access-type)
+  (let* ((parts (string-split exe "_"))
+         (owner (car parts))
+         (group (cadr parts))
+         (gpid (group-information group))
+         (req_grpid (if (equal? group "none")
+                      group 
+                      (if (equal? gpid #f)
+                           #f      
+                     (caddr gpid))))
+ 
+         (current-grp-list (get-groups))
+         (valid-grp (if (equal? group "none")
+                     group
+                    (is-group-washed req_grpid current-grp-list))))
+         (if (not (equal? username owner))
+            (begin
+              (print "You cannot update " area ". Only " owner " can update this area!!") 
+               (exit 1)))
+          (copy-exe access-type exe group)
+           (print "recording action..")    
+          (sauthorize:db-do   (lambda (db)
+             
+             (sauthorize:db-qry db (conc "INSERT INTO actions (cmd,user_id,area_id,action_type ) VALUES ('sauthorize update " area " --" access-type "'," (car (get-user username)) "," (car (get-area area)) ", 'update' )"))))
+         (print "Area has " area "  been update!!" )))
+
+(define (sauthorize:grant auser guser area exp-date access-type restrict)
+    ; check if user exist in db
+    (let* ((area-obj (get-area area))
+           (auser-obj (get-user auser)) 
+           (user-obj (get-user guser)))
+          
+        (if (null? user-obj)
+           (begin
+            ;; is guser a valid unix user
+            (if (not (sauthorize:valid-unix-user guser))
+               (begin  
+                (print "User " guser " is Invalid unix user!!")
+                 (exit 1)))
+            (sauthorize:db-do   (lambda (db)
+             (sauthorize:db-qry db (conc "insert into users (username, is_admin) values ('" guser "', 'no') "))))
+             (set! user-obj (get-user guser))))
+        (let* ((perm-obj (get-perm (car user-obj) (car area-obj))))
+          (if(null? perm-obj)
+          (begin   
+            ;; insert permissions
+            (sauthorize:db-do   (lambda (db)
+            (sauthorize:db-qry db (conc "insert into permissions (access_type, user_id, area_id, restriction, expiration ) values ('" access-type "', " (car user-obj) ", " (car area-obj) ", '" restrict "', '" exp-date "')")))))
+          (begin 
+             ;update permissions
+             (sauthorize:db-do   (lambda (db)
+             (sauthorize:db-qry db (conc "update permissions set access_type = '" access-type "' , restriction = '" restrict "', expiration =  '" exp-date "' where user_id = " (car user-obj) " and area_id = " (car area-obj)))))))
+             (sauthorize:db-do   (lambda (db)
+             (sauthorize:db-qry db (conc "INSERT INTO actions (cmd,user_id,area_id,action_type ) VALUES ('sauthorize grant " guser " --area " area " --expiration " exp-date " --" access-type " --restrict " restrict "'," (car auser-obj) "," (car area-obj) ", 'grant' )"))))  
+             (print "Permission has been sucessfully granted to user " guser))))
+
+(define (sauthorize:process-action  username action . args)
+   (case (string->symbol action)
+   ((grant)
+      (if (< (length args) 6)
+         (begin 
+	     (print  "ERROR: Missing arguments; " (string-intersperse args ", "))
+	     (exit 1)))
+       (let* ((remargs     (args:get-args args '("--area" "--expiration" "--restrict") '() args:arg-hash 0))
+              (guser     (car args))
+	      (restrict         (or (args:get-arg "--restrict") ""))
+              (area         (or (args:get-arg "--area") ""))  
+              (exp-date        (or (args:get-arg "--expiration") ""))
+              (access-type (get-access-type remargs)))
+	; (print  "version " guser " restrict " restrict )
+        ; (print "area " area " exp-date " exp-date " access-type " access-type)
+        (cond
+           ((equal? guser "")
+              (print "Username not found!! Try \"sauthorize help\" for useage ")
+               (exit 1))   
+           ((equal? area "")
+              (print "Area not found!! Try \"sauthorize help\" for useage ")
+              (exit 1)) 
+           ((equal? access-type #f)
+              (print "Access type not found!! Try \"sauthorize help\" for useage ")
+               (exit 1)) 
+           ((equal? exp-date "")
+              (print "Date of expiration not found!! Try \"sauthorize help\" for useage ")
+              (exit 1)))
+           (if (not (area-exists area))
+              (begin
+              (print "Area does not exisit!!")
+              (exit 1)))   
+           (if (can-grant-perm username access-type area)
+	   (begin
+             (print "calling sauthorize:grant ") 
+              (sauthorize:grant username guser area exp-date access-type restrict))   
+           (begin
+              (print "User " username " does not have permission to grant permissions to area " area "!!")
+              (exit 1)))))
+       ((list-area-user)
+          (if (not (equal? (length args) 1))
+              (begin
+              (print "Missing argument area code to list-area-user ") 
+              (exit 1)))
+           (let* ((area (car args)))
+           (if (not (area-exists area))
+              (begin
+              (print "Area does not exisit!!")
+              (exit 1))) 
+                                
+                (sauthorize:list-areausers  area )
+              ))
+      ((read-shell)
+          (if (not (equal? (length args) 1))
+              (begin
+              (print "Missing argument area code to read-shell ") 
+              (exit 1)))
+           (let* ((area (car args))
+                  (code-obj (get-obj-by-code area)))
+           (if (or (null? code-obj)
+                   (not (exe-exist (cadr code-obj)  "retrieve")))
+              (begin
+              (print "Area " area " is not open for reading!!")
+              (exit 1))) 
+              (sauthorize:do-as-calling-user
+             (lambda ()
+                (run-cmd (conc *exe-path* "/retrieve/" (cadr code-obj) ) (list "shell" area ))))))
+      ((write-shell)
+          (if (not (equal? (length args) 1))
+              (begin
+              (print "Missing argument area code to read-shell ") 
+              (exit 1)))
+           (let* ((area (car args))
+                  (code-obj (get-obj-by-code area)))
+           (if (or (null? code-obj)
+                   (not (exe-exist (cadr code-obj)  "publish")))
+              (begin
+              (print "Area " area " is not open for Writing!!")
+              (exit 1))) 
+              (sauthorize:do-as-calling-user
+             (lambda ()
+                (run-cmd (conc *exe-path* "/publish/" (cadr code-obj) ) (list "shell" area))))))
+      ((publish)
+          (if (< (length args) 2)
+              (begin
+              (print "Missing argument to publish. \n publish   [opts] ") 
+              (exit 1)))
+            
+           (let* ((action (car args))
+                  (area (cadr args))
+                  (cmd-args (cddr args)) 
+                  (code-obj (get-obj-by-code area)))
+           ;(print "area " area)
+           ;(print "code: " code-obj)  
+           ;(print (exe-exist (cadr code-obj)  "publish")) 
+           (if (or (null? code-obj)
+                   (not (exe-exist (cadr code-obj)  "publish")))
+              (begin
+              (print "Area " area " is not open for writing!!")
+              (exit 1)))
+              ;(print "hear") 
+              (sauthorize:do-as-calling-user
+             (lambda ()
+               ; (print  *exe-path* "/publish/" (cadr code-obj) action area cmd-args  )
+                (run-cmd (conc *exe-path* "/publish/" (cadr code-obj) ) (append (list action area ) cmd-args))))))
+      
+     ((retrieve)
+          (if (< (length args) 2)
+              (begin
+              (print "Missing argument to publish. \n publish   [opts] ") 
+              (exit 1)))
+           (let* ((action (car args))
+                  (area (cadr args))
+                  (cmd-args (cddr args)) 
+                  (code-obj (get-obj-by-code area)))
+           (if (or (null? code-obj)
+                   (not (exe-exist (cadr code-obj)  "retrieve")))
+              (begin
+              (print "Area " area " is not open for reading!!")
+              (exit 1))) 
+               (print (conc *exe-path* "/retrieve/" (cadr code-obj) " " action " " area " " (string-join cmd-args)))
+              (sauthorize:do-as-calling-user
+             (lambda ()
+                (run-cmd (conc *exe-path* "/retrieve/" (cadr code-obj) ) (append (list action area ) cmd-args))))))
+
+ 
+ 
+      ((open)
+         (if (< (length args) 6)
+              (begin
+              (print "sauthorize open cmd takes 6 arguments!! \n Useage: sauthorize open  --group  --code  --retrieve|--publish") 
+              (exit 1)))
+         (let* ((remargs     (args:get-args args '("--group" "--code" "--additional-grps") '() args:arg-hash 0))
+              (path     (car args))
+	      (group         (or (args:get-arg "--group") ""))
+              (area         (or (args:get-arg "--code") ""))
+              (other-grps          (or (args:get-arg "--additional-grps") ""))     
+              (access-type (get-access-type remargs)))
+                
+              (cond
+                ((equal? path "")
+                  (print "path not found!! Try \"sauthorize help\" for useage ")
+                  (exit 1))   
+                ((equal? area "")
+                  (print "--code not found!! Try \"sauthorize help\" for useage ")
+                  (exit 1)) 
+                ((equal? access-type #f)
+                  (print "Access type not found!! Try \"sauthorize help\" for useage ")
+                  (exit 1)) 
+                ((and (not (equal? access-type "publish")) 
+                  (not (equal? access-type "retrieve")))
+                  (print "Access type can be eiter --retrieve or --publish !! Try \"sauthorize help\" for useage ")
+                  (exit 1)))
+                ; (print other-grps) 
+                (sauthorize:open username path group area access-type other-grps)))
+         ((update)
+            (if (< (length args) 2)
+              (begin
+              (print "sauthorize update cmd takes 2 arguments!! \n Useage: sauthorize update  --retrieve|--publish") 
+              (exit 1)))
+              (let* ((area (car args))
+                     (code-obj (get-obj-by-code area))
+                    (access-type (get-access-type (cdr args))))
+               (if  (and (not (equal? access-type "publish")) (not (equal? access-type "retrieve")))
+                  (begin 
+                  (print "Access type can be --retrieve|--publish ")
+                  (exit 1)))
+              (if (or (null? code-obj)
+                   (not (exe-exist (cadr code-obj)  access-type)))
+              (begin
+              (print "Area " area " is not open for reading!!")
+              (exit 1))) 
+              (sauthorize:update username (cadr code-obj) area access-type ))) 
+         ((area-admin)
+           (let* ((usr (car args))
+                  (usr-obj (get-user usr))
+                  (user-id (car (get-user username))))
+           
+                (if (is-admin  username)
+                (begin
+                  ; (print usr-obj) 
+                  (if (null? usr-obj)
+                    (begin
+                        (sauthorize:db-do   (lambda (db)
+              ;(print (conc "INSERT INTO users (username,is_admin) VALUES ( '" usr "', 'read-admin' )"))
+             (sauthorize:db-qry db (conc "INSERT INTO users (username,is_admin) VALUES ( '" usr "', 'read-admin' )")))))
+               (begin
+                ; (print (conc "update users set is_admin = 'no' where id = " (car usr-obj) ))
+                 (sauthorize:db-do   (lambda (db)
+                (sauthorize:db-qry db (conc "update users set is_admin = 'read-admin' where id = " (car usr-obj)))))))
+                (print "User " usr " is updated with area-admin access!"))
+                (print "Admin only function"))
+                (sauthorize:db-do   (lambda (db)
+             (sauthorize:db-qry db (conc "INSERT INTO actions (cmd,user_id,area_id,action_type ) VALUES ('area-admin " usr " ', " user-id ",0, 'area-admin ')" )))))) 
+          ((mk-admin)
+           (let* ((usr (car args))
+                  (usr-obj (get-user usr))
+                  (user-id (car (get-user username))))
+                (if (not (sauthorize:valid-unix-user usr))
+               (begin  
+                (print "User " usr " is Invalid unix user!!")
+                 (exit 1)))
+
+                (if (member  username  *super-users*)
+                (begin
+                  (if (null? usr-obj)
+                    (begin
+                        (sauthorize:db-do   (lambda (db)
+                           (sauthorize:db-qry db (conc "INSERT INTO users (username,is_admin) VALUES ( '" usr "', 'yes' )")))))
+               (begin
+                 (sauthorize:db-do   (lambda (db)
+                (sauthorize:db-qry db (conc "update users set is_admin = 'yes' where id = " (car usr-obj)))))))
+                (print "User " usr " is updated with admin access!"))
+                (print "Super-Admin only function"))
+                (sauthorize:db-do   (lambda (db)
+             (sauthorize:db-qry db (conc "INSERT INTO actions (cmd,user_id,area_id,action_type ) VALUES ('mk-admin " usr " ', " user-id ",0, 'mk-admin ')" )))))) 
+
+         ((register-log)
+            (if (< (length args) 4)
+                (print "Invalid arguments"))
+             ;(print args)
+             (let* ((cmd-line (car args))
+                     (user-id (cadr args))
+                     (area-id (caddr args))
+                     (user-obj (get-user username))
+                      (cmd (cadddr args)))
+                
+               (if (and (not (null? user-obj)) (equal? user-id (number->string(car user-obj))))
+                (begin 
+                (sauthorize:db-do   (lambda (db)
+             (sauthorize:db-qry db (conc "INSERT INTO actions (cmd,user_id,area_id,action_type ) VALUES ('" cmd-line"', " user-id "," area-id ", '" cmd "')" )))))
+                (print "You ar not authorised to run this cmd")
+
+)))     
+
+       
+      (else (print 0 "Unrecognised command " action))))
+  
+(define (main)
+  (let* ((args      (argv))
+	 (prog      (car args))
+	 (rema      (cdr args))
+         (username     (current-user-name)))
+    ;; preserve the exe data in the config file
+    (cond
+     ;; one-word commands
+     ((eq? (length rema) 1)
+      (case (string->symbol (car rema))
+	((help -h -help --h --help)
+	 (print sauthorize:help))
+	((list)
+            
+          (sauthorize:db-do  (lambda (db)
+				     (print "My Area accesses: ")
+				     (query (for-each-row
+					     (lambda (row)
+                                               (let* ((exp-date (car row)))
+                                                (if  (is-access-valid  exp-date)     
+					           (apply print (intersperse (cdr row) " | "))))))
+					    (sql db (conc "SELECT permissions.expiration, areas.basepath, areas.code, permissions.access_type  FROM users, areas, permissions where permissions.user_id = users.id and permissions.area_id = areas.id and users.username = '" username "'"))))))
+         
+	((log)
+	 (sauthorize:db-do  (lambda (db)
+				     (print "Logs : ")
+				     (query (for-each-row
+					     (lambda (row)
+                                                   
+					       (apply print (intersperse row " | "))))
+					    (sql db "SELECT actions.cmd, users.username, actions.action_type, actions.datetime, areas.code  FROM actions, users, areas where actions.user_id = users.id and actions.area_id = areas.id ")))))
+	(else
+	 (print "ERROR: Unrecognised command. Try \"sauthorize help\""))))
+     ;; multi-word commands
+     ((null? rema)(print sauthorize:help))
+     ((>= (length rema) 2)
+      (apply sauthorize:process-action username (car rema)(cdr rema)))
+     (else (debug:print 0 "ERROR: Unrecognised command. Try \"sauthorize help\"")))))
+
+(main)
+
+
+      

ADDED   scratch.org
Index: scratch.org
==================================================================
--- /dev/null
+++ scratch.org
@@ -0,0 +1,16 @@
+* template variables
+- run-id
+- test-id
+- item-test-path
+- runname
+- test-name
+- target
+* launch-type
+- in an xterm (common:run-a-command ... )
+* insertion
+[custom-context-menu-items]
+item1=Menu Item Text:$MT_RUN_AREA_HOME/../bin/nbdiag -test-id %test-id -test-path %item-test-path
+item2=netbatch_diagnose:$MT_RUN_AREA_HOME/../bin/nbdiag -test-id %test-id -test-path %item-test-path
+
+
+

Index: sdb.scm
==================================================================
--- sdb.scm
+++ sdb.scm
@@ -22,11 +22,11 @@
 (declare (unit sdb))
 
 ;; 
 (define (sdb:open fname)
   (let* ((dbpath    (pathname-directory fname))
-	 (dbexists  (let ((fe (file-exists? fname)))
+	 (dbexists  (let ((fe (common:file-exists? fname)))
 		      (if fe 
 			  fe
 			  (begin
 			    (create-directory dbpath #t)
 			    #f))))

Index: server.scm
==================================================================
--- server.scm
+++ server.scm
@@ -1,31 +1,39 @@
 
-;; 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 program is distributed WITHOUT ANY WARRANTY; without even the
-;;  implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
-;;  PURPOSE.
+;; 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-extension (srfi 18) extras tcp s11n)
 
-(use srfi-1 posix regex regex-case srfi-69 hostinfo md5 message-digest directory-utils posix-extras matchable)
-;; (use zmq)
+(use srfi-1 posix regex regex-case srfi-69 hostinfo md5 message-digest
+     directory-utils posix-extras matchable)
 
 (use spiffy uri-common intarweb http-client spiffy-request-vars)
 
 (declare (unit server))
 
 (declare (uses common))
 (declare (uses db))
 (declare (uses tasks)) ;; tasks are where stuff is maintained about what is running.
-(declare (uses synchash))
+;; (declare (uses synchash))
 (declare (uses http-transport))
-(declare (uses rpc-transport))
-;;(declare (uses nmsg-transport))
+;;(declare (uses rpc-transport))
 (declare (uses launch))
 (declare (uses daemon))
 
 (include "common_records.scm")
 (include "db_records.scm")
@@ -34,10 +42,22 @@
   (if (not hostport)
       #f
       (conc "http://" (car hostport) ":" (cadr hostport))))
 
 (define  *server-loop-heart-beat* (current-seconds))
+
+;;======================================================================
+;; P K T S   S T U F F 
+;;======================================================================
+
+;; ???
+
+;;======================================================================
+;; P K T S   S T U F F 
+;;======================================================================
+
+;; ???
 
 ;;======================================================================
 ;; S E R V E R
 ;;======================================================================
 
@@ -50,11 +70,11 @@
 ;;
 (define (server:launch run-id transport-type)
   (case transport-type
     ((http)(http-transport:launch))
     ;;((nmsg)(nmsg-transport:launch run-id))
-    ((rpc)  (rpc-transport:launch run-id))
+    ;;((rpc)  (rpc-transport:launch run-id))
     (else (debug:print-error 0 *default-log-port* "unknown server type " transport-type))))
 
 ;;======================================================================
 ;; S E R V E R   U T I L I T I E S 
 ;;======================================================================
@@ -112,11 +132,12 @@
 		      " -server " (or target-host "-") (if (equal? (configf:lookup *configdat* "server" "daemonize") "yes")
 							   " -daemonize "
 							   "")
 		      ;; " -log " logfile
 		      " -m testsuite:" testsuite)) ;; (conc " >> " logfile " 2>&1 &")))))
-	 (log-rotate  (make-thread common:rotate-logs  "server run, rotate logs thread")))
+	 (log-rotate  (make-thread common:rotate-logs  "server run, rotate logs thread"))
+         (load-limit  (configf:lookup-number *configdat* "jobtools" "max-server-start-load" default: 3.0)))
     ;; we want the remote server to start in *toppath* so push there
     (push-directory areapath)
     (debug:print 0 *default-log-port* "INFO: Trying to start server (" cmdln ") ...")
     (thread-start! log-rotate)
     
@@ -129,11 +150,12 @@
 	(begin
 	  (debug:print-info 0 *default-log-port* "Starting server on " target-host ", logfile is " logfile)
 	  (setenv "TARGETHOST" target-host)))
       
     (setenv "TARGETHOST_LOGF" logfile)
-    (common:wait-for-normalized-load 4 " delaying server start due to load" remote-host: (get-environment-variable "TARGETHOST")) ;; do not try starting servers on an already overloaded machine, just wait forever
+    (thread-sleep! (/ (random 5000) 1000)) ;; add about a random (up to 5 seconds) initial delay. It seems pretty common that many running tests request a server at the same time
+    (common:wait-for-normalized-load load-limit " delaying server start due to load" target-host) ;; do not try starting servers on an already overloaded machine, just wait forever
     (system (conc "nbfake " cmdln))
     (unsetenv "TARGETHOST_LOGF")
     (if (get-environment-variable "TARGETHOST")(unsetenv "TARGETHOST"))
     (thread-join! log-rotate)
     (pop-directory)))
@@ -206,11 +228,25 @@
 		(if (null? tal)
 		    (if (and limit
 			     (> (length new-res) limit))
 			new-res ;; (take new-res limit)  <= need intelligent sorting before this will work
 			new-res)
-		      (loop (car tal)(cdr tal) new-res)))))))))
+		    (loop (car tal)(cdr tal) new-res)))))))))
+
+(define (server:get-num-alive srvlst)
+  (let ((num-alive 0))
+    (for-each
+     (lambda (server)
+       (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)))
+	   (if (< uptime 5)(set! num-alive (+ num-alive 1))))))
+     srvlst)
+    num-alive))
 
 ;; given a list of servers get a list of valid servers, i.e. at least
 ;; 10 seconds old, has started and is less than 1 hour old and is
 ;; active (i.e. mod-time < 10 seconds
 ;;
@@ -230,11 +266,11 @@
 				    (mod-time   (list-ref rec 0)))
 				;; (print "start-time: " start-time " mod-time: " mod-time)
 				(and start-time mod-time
 				     (> (- now start-time) 0)    ;; been running at least 0 seconds
 				     (< (- now mod-time)   16)   ;; still alive - file touched in last 16 seconds
-				     (< (- now start-time) 
+				     (< (- now start-time)       
 					(+ (- (string->number (or (configf:lookup *configdat* "server" "runtime") "3600"))
 					      180)
 					   (random 360))) ;; under one hour running time +/- 180
 				     ))
 			      #f))
@@ -424,16 +460,161 @@
     (set! *db-last-access* (current-seconds)) ;; might not be needed.
     (if (equal? *toppath* toppath)
 	#t
 	#f)))
 
-;; timeout is in hours
-(define (server:get-timeout)
-  (let ((tmo (configf:lookup  *configdat* "server" "timeout")))
+;; timeout is hms string: 1h 5m 3s, default is 1 minute
+;;
+(define (server:expiration-timeout)
+  (let ((tmo (configf:lookup *configdat* "server" "timeout")))
     (if (and (string? tmo)
-	     (string->number tmo))
-	(* 60 60 (string->number tmo))
-	;; (* 3 24 60 60) ;; default to three days
-	;;(* 60 60 1)     ;; default to one hour
-	(* 60 5)          ;; default to five minutes
-	)))
+	     (common:hms-string->seconds tmo)) ;; BUG: hms-string->seconds is broken, if given "10" returns 0. Also, it doesn't belong in this logic unless the string->number is changed below
+        (* 3600 (string->number tmo))
+	60)))
+
+(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)))) ".")))
+
+;; moving this here as it needs access to db and cannot be in common.
+;;
+(define (server:writable-watchdog dbstruct)
+  (thread-sleep! 0.05) ;; delay for startup
+  (let ((legacy-sync  (common:run-sync?))
+        (sync-stale-seconds (configf:lookup-number *configdat* "server" "sync-stale-seconds" default: 300))
+	(debug-mode   (debug:debug-mode 1))
+	(last-time    (current-seconds))
+	(no-sync-db   (db:open-no-sync-db))
+        (sync-duration 0) ;; run time of the sync in milliseconds
+        ;;(this-wd-num  (begin (mutex-lock! *wdnum*mutex) (let ((x *wdnum*)) (set! *wdnum* (add1 *wdnum*)) (mutex-unlock! *wdnum*mutex) x)))
+        )
+    (set! *no-sync-db* no-sync-db) ;; make the no sync db available to api calls
+    (debug:print-info 2 *default-log-port* "Periodic sync thread started.")
+    (debug:print-info 3 *default-log-port* "watchdog starting. legacy-sync is " legacy-sync" pid="(current-process-id)  );;  " this-wd-num="this-wd-num)
+    (if (and legacy-sync (not *time-to-exit*))
+	(let* (;;(dbstruct (db:setup))
+	       (mtdb       (dbr:dbstruct-mtdb dbstruct))
+	       (mtpath     (db:dbdat-get-path mtdb))
+	       (tmp-area   (common:get-db-tmp-area))
+	       (start-file (conc tmp-area "/.start-sync"))
+	       (end-file   (conc tmp-area "/.end-sync")))
+	  (debug:print-info 0 *default-log-port* "Server running, periodic sync started.")
+	  (let loop ()
+	    ;; sync for filesystem local db writes
+	    ;;
+	    (mutex-lock! *db-multi-sync-mutex*)
+	    (let* ((need-sync        (>= *db-last-access* *db-last-sync*)) ;; no sync since last write
+		   (sync-in-progress *db-sync-in-progress*)
+                   (min-intersync-delay (configf:lookup-number *configdat* "server" "minimum-intersync-delay" default: 5))
+		   (should-sync      (and (not *time-to-exit*)
+                                          (> (- (current-seconds) *db-last-sync*) min-intersync-delay))) ;; sync every five seconds minimum, deprecated logic, can probably be removed
+		   (start-time       (current-seconds))
+                   (cpu-load-adj     (alist-ref 'adj-proc-load (common:get-normalized-cpu-load #f)))
+		   (mt-mod-time      (file-modification-time mtpath))
+		   (last-sync-start  (if (common:file-exists? start-file)
+					 (file-modification-time start-file)
+					 0))
+		   (last-sync-end    (if (common:file-exists? end-file)
+					 (file-modification-time end-file)
+					 10))
+                   (sync-period      (+ 3 (* cpu-load-adj 30))) ;; as adjusted load increases increase the sync period
+		   (recently-synced  (and (< (- start-time mt-mod-time) sync-period) ;; not useful if sync didn't modify megatest.db!
+					  (< mt-mod-time last-sync-start)))
+		   (sync-done        (<= last-sync-start last-sync-end))
+                   (sync-stale       (> start-time (+ last-sync-start sync-stale-seconds)))
+		   (will-sync        (and (not *time-to-exit*)       ;; do not start a sync if we are in the process of exiting
+                                          (or need-sync should-sync)
+					  (or sync-done sync-stale)
+					  (not sync-in-progress)
+					  (not recently-synced))))
+              (debug:print-info 13 *default-log-port* "WD writable-watchdog top of loop.  need-sync="need-sync" sync-in-progress=" sync-in-progress
+				" should-sync="should-sync" start-time="start-time" mt-mod-time="mt-mod-time" recently-synced="recently-synced" will-sync="will-sync
+				" sync-done=" sync-done " sync-period=" sync-period)
+              (if (and (> sync-period 5)
+                       (common:low-noise-print 30 "sync-period"))
+                  (debug:print-info 0 *default-log-port* "Increased sync period due to long sync times, sync took: " sync-period " seconds."))
+	      ;; (if recently-synced (debug:print-info 0 *default-log-port* "Skipping sync due to recently-synced flag=" recently-synced))
+	      ;; (debug:print-info 0 *default-log-port* "need-sync: " need-sync " sync-in-progress: " sync-in-progress " should-sync: " should-sync " will-sync: " will-sync)
+	      (if will-sync (set! *db-sync-in-progress* #t))
+	      (mutex-unlock! *db-multi-sync-mutex*)
+	      (if will-sync
+                  (let (;; (max-sync-duration  (configf:lookup-number *configdat* "server" "max-sync-duration")) ;; KEEPING THIS AVAILABLE BUT SHOULD NOT USE, I'M PRETTY SURE IT DOES NOT WORK!
+                        (sync-start         (current-milliseconds)))
+		    (with-output-to-file start-file (lambda ()(print (current-process-id))))
+		    
+		    ;; put lock here
+		    
+                    ;; (if (or (not max-sync-duration)
+                    ;;        (< sync-duration max-sync-duration)) ;; NOTE: db:sync-to-megatest.db keeps track of time of last sync and syncs incrementally
+                        (let ((res        (db:sync-to-megatest.db dbstruct no-sync-db: no-sync-db))) ;; did we sync any data? If so need to set the db touched flag to keep the server alive
+                          (set! sync-duration (- (current-milliseconds) sync-start))
+                          (if (> res 0) ;; some records were transferred, keep the db alive
+                              (begin
+                                (mutex-lock! *heartbeat-mutex*)
+                                (set! *db-last-access* (current-seconds))
+                                (mutex-unlock! *heartbeat-mutex*)
+                                (debug:print-info 0 *default-log-port* "sync called, " res " records transferred."))
+                              (debug:print-info 2 *default-log-port* "sync called but zero records transferred")))))
+;;                         ;; TODO: factor this next routine out into a function
+;;                         (with-input-from-pipe ;; this should not block other threads but need to verify this
+;;                          (conc "megatest -sync-to-megatest.db -m testsuite:" (common:get-area-name) ":" *toppath*)
+;;                          (lambda ()
+;;                            (let loop ((inl (read-line))
+;;                                       (res #f))
+;;                              (if (eof-object? inl)
+;;                                  (begin
+;;                                    (set! sync-duration (- (current-milliseconds) sync-start))
+;;                                    (cond
+;;                                     ((not res)
+;;                                      (debug:print 0 *default-log-port* "ERROR: sync from /tmp db to megatest.db appears to have failed. Recommended that you stop your runs and run \"megatest -cleanup-db\""))
+;;                                     ((> res 0)
+;;                                      (mutex-lock! *heartbeat-mutex*)
+;;                                      (set! *db-last-access* (current-seconds))
+;;                                      (mutex-unlock! *heartbeat-mutex*))))
+;;                                  (let ((num-synced (let ((matches (string-match "^Synced (\\d+).*$" inl)))
+;;                                                      (if matches
+;;                                                          (string->number (cadr matches))
+;;                                                          #f))))
+;;                                    (loop (read-line)
+;;                                          (or num-synced res))))))))))
+	      (if will-sync
+		  (begin
+		    (mutex-lock! *db-multi-sync-mutex*)
+		    (set! *db-sync-in-progress* #f)
+		    (set! *db-last-sync* start-time)
+		    (with-output-to-file end-file (lambda ()(print (current-process-id))))
+
+		    ;; release lock here
+
+		    (mutex-unlock! *db-multi-sync-mutex*)))
+	      (if (and debug-mode
+		       (> (- start-time last-time) 60))
+		  (begin
+		    (set! last-time start-time)
+		    (debug:print-info 4 *default-log-port* "timestamp -> " (seconds->time-string (current-seconds)) ", time since start -> " (seconds->hr-min-sec (- (current-seconds) *time-zero*))))))
+	    
+	    ;; keep going unless time to exit
+	    ;;
+	    (if (not *time-to-exit*)
+		(let delay-loop ((count 0))
+                  ;;(debug:print-info 13 *default-log-port* "delay-loop top; count="count" pid="(current-process-id)" this-wd-num="this-wd-num" *time-to-exit*="*time-to-exit*)
+                                                            
+		  (if (and (not *time-to-exit*)
+			   (< count 6)) ;; was 11, changing to 4. 
+		      (begin
+			(thread-sleep! 1)
+			(delay-loop (+ count 1))))
+		  (if (not *time-to-exit*) (loop))))
+	    ;; time to exit, close the no-sync db here
+	    (db:no-sync-close-db no-sync-db)
+	    (if (common:low-noise-print 30)
+		(debug:print-info 0 *default-log-port* "Exiting watchdog timer, *time-to-exit* = " *time-to-exit*" pid="(current-process-id) ))))))) ;;" this-wd-num="this-wd-num)))))))
 

ADDED   show-uncalled-procedures.scm
Index: show-uncalled-procedures.scm
==================================================================
--- /dev/null
+++ show-uncalled-procedures.scm
@@ -0,0 +1,28 @@
+;; 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")
+
+(define (show-danglers)
+  (let* ((all-scm-files (glob "*.scm"))
+         (xref (get-xref all-scm-files))
+         (dangling-procs
+          (map car (filter (lambda (x) (equal? 1 (length x))) xref))))
+    (for-each print dangling-procs) ;; our product.
+    ))
+
+(show-danglers)
+
+    

DELETED spreadsheet/basic/Configurations2/accelerator/current.xml
Index: spreadsheet/basic/Configurations2/accelerator/current.xml
==================================================================
--- spreadsheet/basic/Configurations2/accelerator/current.xml
+++ /dev/null

DELETED spreadsheet/basic/META-INF/manifest.xml
Index: spreadsheet/basic/META-INF/manifest.xml
==================================================================
--- spreadsheet/basic/META-INF/manifest.xml
+++ /dev/null
@@ -1,22 +0,0 @@
-
-
- 
- 
- 
- 
- 
- 
- 
- 
- 
- 
- 
- 
- 
- 
- 
- 
- 
- 
- 
-

DELETED spreadsheet/basic/Thumbnails/thumbnail.png
Index: spreadsheet/basic/Thumbnails/thumbnail.png
==================================================================
--- spreadsheet/basic/Thumbnails/thumbnail.png
+++ /dev/null
cannot compute difference between binary files

DELETED spreadsheet/basic/content.xml
Index: spreadsheet/basic/content.xml
==================================================================
--- spreadsheet/basic/content.xml
+++ /dev/null
@@ -1,132 +0,0 @@
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-Row 1,A
-
-
-Row 1,B
-
-
-
-
-Row 2,A
-
-
-Row 2,B
-
-
-
-
-
-
-
-this is sheet one
-
-
-
-
-
-
-
-
-Row 1,A
-
-
-Row 1,B
-
-
-
-
-Row 2,A
-
-
-Row 2,B
-
-
-
-
-
-
-
-this is sheet two
-
-
-
-
-
-
-
-
-1
-
-
-2
-
-
-
-
-2
-
-
-4
-
-
-
-
-3
-
-
-6
-
-
-
-
-4
-
-
-8
-
-
-
-
-5
-
-
-10
-
-
-
-
-6
-
-
-12
-
-
-
-
-
-

DELETED spreadsheet/basic/content.xml~
Index: spreadsheet/basic/content.xml~
==================================================================
--- spreadsheet/basic/content.xml~
+++ /dev/null
@@ -1,2 +0,0 @@
-
-Row 1,ARow 1,BRow 2,ARow 2,Bthis is sheet oneRow 1,ARow 1,BRow 2,ARow 2,Bthis is sheet two12243648510612

DELETED spreadsheet/basic/meta.xml
Index: spreadsheet/basic/meta.xml
==================================================================
--- spreadsheet/basic/meta.xml
+++ /dev/null
@@ -1,2 +0,0 @@
-
-Matt Welland2011-09-06T20:46:232011-09-06T22:05:47Matt WellandPT1H19M25S2LibreOffice/3.3$Linux LibreOffice_project/330m19$Build-301

DELETED spreadsheet/basic/mimetype
Index: spreadsheet/basic/mimetype
==================================================================
--- spreadsheet/basic/mimetype
+++ /dev/null
@@ -1,1 +0,0 @@
-application/vnd.oasis.opendocument.spreadsheet

DELETED spreadsheet/basic/settings.xml
Index: spreadsheet/basic/settings.xml
==================================================================
--- spreadsheet/basic/settings.xml
+++ /dev/null
@@ -1,2 +0,0 @@
-
-0045161799view100000020000010060true04000020000010060true15000020000010060trueSheet3270010060falsetruetruetrue12632256truetruetruetruefalsefalse1270127011truefalsetrue3falsetruetruetrue12701270false1truetrue1true12632256falsefalsetrue0truetruetruefalsetrue

DELETED spreadsheet/basic/styles.xml
Index: spreadsheet/basic/styles.xml
==================================================================
--- spreadsheet/basic/styles.xml
+++ /dev/null
@@ -1,2 +0,0 @@
-
-$-$???Page 1??? (???)09/06/2011, 22:05:47Page 1 / 99

Index: spublish.scm
==================================================================
--- spublish.scm
+++ spublish.scm
@@ -7,61 +7,48 @@
 ;;  This program is distributed WITHOUT ANY WARRANTY; without even the
 ;;  implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
 ;;  PURPOSE.
 
 (use defstruct)
-
-;; (use ssax)
-;; (use sxml-serializer)
-;; (use sxml-modifications)
-;; (use regex)
-;; (use srfi-69)
-;; (use regex-case)
-;; (use posix)
-;; (use json)
-;; (use csv)
+(use scsh-process)
+(use refdb)
 (use srfi-18)
+(use srfi-19)
 (use format)
-
-;; (require-library ini-file)
-;; (import (prefix ini-file ini:))
-
 (use sql-de-lite srfi-1 posix regex regex-case srfi-69)
-;; (import (prefix sqlite3 sqlite3:))
-;; 
+
 (declare (uses configf))
 ;; (declare (uses tree))
 (declare (uses margs))
-;; (declare (uses dcommon))
-;; (declare (uses launch))
-;; (declare (uses gutils))
-;; (declare (uses db))
-;; (declare (uses synchash))
-;; (declare (uses server))
+
 (declare (uses megatest-version))
 ;; (declare (uses tbd))
 
 (include "megatest-fossil-hash.scm")
+;;; please create this file before using sautherise. For sample file is avaliable sample-sauth-paths.scm. 
+(include "sauth-paths.scm")
+(include "sauth-common.scm")
+(define (toplevel-command . args) #f)
+(use readline)
 
 ;;
 ;; GLOBALS
 ;;
 (define *spublish:current-tab-number* 0)
 (define *args-hash* (make-hash-table))
-(define spublish:help (conc "Usage: spublish [action [params ...]]
-
-  ls                     : list contents of target area
-  cp|publish        : copy file to target area
-  mkdir        : maks directory in target area  
-  rm               : remove file  from target area
-  ln   : creates a symlink
-  log                    :
-
+(define spublish:help (conc "Usage: spublish  [action [params ...]]
+
+  ls                     : list contents of target area
+  cp|publish         : copy file to target area
+  mkdir         : maks directory in target area  
+  rm                : remove file  from target area
+  ln    : creates a symlink
+ 
   options:
 
     -m \"message\"        : describe what was done
-
+Note: All the target locations relative to base path 
 Part of the Megatest tool suite.
 Learn more at http://www.kiatoa.com/fossils/megatest
 
 Version: " megatest-fossil-hash)) ;; "
 
@@ -71,237 +58,240 @@
 
 ;;======================================================================
 ;; DB
 ;;======================================================================
 
-(define (spublish:initialize-db db)
-  (for-each
-   (lambda (qry)
-     (exec (sql db qry)))
-   (list 
-    "CREATE TABLE IF NOT EXISTS actions
-         (id           INTEGER PRIMARY KEY,
-          action       TEXT NOT NULL,
-          submitter    TEXT NOT NULL,
-          datetime     TIMESTAMP DEFAULT (strftime('%s','now')),
-          srcpath      TEXT NOT NULL,
-          comment      TEXT DEFAULT '' NOT NULL,
-          state        TEXT DEFAULT 'new');"
-    )))
-
-(define (spublish:register-action db action submitter source-path comment)
-  (exec (sql db "INSERT INTO actions (action,submitter,srcpath,comment)
-                 VALUES(?,?,?,?)")
-	action
-	submitter
-	source-path
-	comment))
+(define *default-log-port* (current-error-port))
+(define *verbosity*         1)
+
+;(define (spublish:initialize-db db)
+;  (for-each
+;   (lambda (qry)
+;     (exec (sql db qry)))
+;   (list 
+;    "CREATE TABLE IF NOT EXISTS actions
+;         (id           INTEGER PRIMARY KEY,
+;          action       TEXT NOT NULL,
+;          submitter    TEXT NOT NULL,
+;          datetime     TIMESTAMP DEFAULT (strftime('%s','now')),
+;          srcpath      TEXT NOT NULL,
+;          comment      TEXT DEFAULT '' NOT NULL,
+;          state        TEXT DEFAULT 'new');"
+;    )))
+
+;(define (spublish:register-action db action submitter source-path comment)
+;  (exec (sql db "INSERT INTO actions (action,submitter,srcpath,comment)
+;                 VALUES(?,?,?,?)")
+;	action
+;	submitter
+;	source-path
+;	comment))
 
 ;; (call-with-database
 ;;  (lambda (db)
 ;;   (set-busy-handler! db (busy-timeout 10000)) ; 10 second timeout
 ;;   ...))
 
 ;; Create the sqlite db
-(define (spublish:db-do configdat proc) 
-  (let ((path (configf:lookup configdat "database" "location")))
-    (if (not path)
-	(begin
-	  (print "[database]\nlocation /some/path\n\n Is missing from the config file!")
-	  (exit 1)))
-    (if (and path
-	     (directory? path)
-	     (file-read-access? path))
-	(let* ((dbpath    (conc path "/spublish.db"))
-	       (writeable (file-write-access? dbpath))
-	       (dbexists  (file-exists? dbpath)))
-	  (handle-exceptions
-	   exn
-	   (begin
-	     (debug:print 2 *default-log-port* "ERROR: problem accessing db " dbpath
-			  ((condition-property-accessor 'exn 'message) exn))
-	     (exit 1))
-	   (call-with-database
-            dbpath
-	    (lambda (db)
-	      ;; (print "calling proc " proc " on db " db)
-	      (set-busy-handler! db (busy-timeout 10000)) ;; 10 sec timeout
-	      (if (not dbexists)(spublish:initialize-db db))
-	      (proc db)))))
-	(print "ERROR: invalid path for storing database: " path))))
-
-;; copy in file to dest, validation is done BEFORE calling this
-;;
-(define (spublish:cp configdat submitter source-path target-dir targ-file dest-dir comment)
-  (let ((dest-dir-path (conc target-dir "/" dest-dir))
-        (targ-path (conc target-dir "/" dest-dir "/" targ-file)))
-    (if (file-exists? targ-path)
-	(begin
-	  (print "ERROR: target file already exists, remove it before re-publishing")
-	  (exit 1)))
-       (if (not(file-exists? dest-dir-path))
-	(begin
-	  (print "ERROR: target directory " dest-dir-path " does not exists." )
-	  (exit 1)))
-
-    (spublish:db-do
-     configdat
-     (lambda (db)
-       (spublish:register-action db "cp" submitter source-path comment)))
-    (let* (;; (target-path (configf:lookup "settings" "target-path"))
-	   (th1         (make-thread
-			 (lambda ()
-			   (file-copy source-path targ-path #t))
-                            (print " ... file " targ-path " copied to" targ-path)
-			 ;; (let ((pid (process-run "cp" (list source-path target-dir))))
-			 ;;   (process-wait pid)))
-			 "copy thread"))
-	   (th2         (make-thread
-			 (lambda ()
-			   (let loop ()
-			     (thread-sleep! 15)
-			     (display ".")
-			     (flush-output)
-			     (loop)))
-			 "action is happening thread")))
-      (thread-start! th1)
-      (thread-start! th2)
-      (thread-join! th1))
-    (cons #t "Successfully saved data")))
-
-;; copy directory to dest, validation is done BEFORE calling this
-;;
-
-(define (spublish:tar configdat submitter target-dir dest-dir comment)
-  (let ((dest-dir-path (conc target-dir "/" dest-dir)))
-       (if (not(file-exists? dest-dir-path))
-	(begin
-	  (print "ERROR: target directory " dest-dir-path " does not exists." )
-	  (exit 1)))
-    ;;(print dest-dir-path )
-    (spublish:db-do
-     configdat
-     (lambda (db)
-       (spublish:register-action db "tar" submitter dest-dir-path comment)))
-       (change-directory dest-dir-path)
-       (process-wait (process-run "/bin/tar" (list "xf" "-")))
-       (print "Data copied to " dest-dir-path) 
-
-        (cons #t "Successfully saved data")))
-
-
-(define (spublish:validate target-dir targ-mk)
-  (let* ((normal-path (normalize-pathname targ-mk))
-        (targ-path (conc target-dir "/" normal-path)))
-    (if (string-contains   normal-path "..")
-    (begin
-      (print "ERROR: Path  " targ-mk " resolved outside target area "  target-dir )
-      (exit 1)))
-
-    (if (not (string-contains targ-path target-dir))
-    (begin
-      (print "ERROR: You cannot update data outside " target-dir ".")
-      (exit 1)))
-    (print "Path " targ-mk " is valid.")   
- ))
+;(define (spublish:db-do configdat proc) 
+;  (let ((path (configf:lookup configdat "database" "location")))
+;    (if (not path)
+;	(begin
+;	  (print "[database]\nlocation /some/path\n\n Is missing from the config file!")
+;	  (exit 1)))
+;    (if (and path
+;	     (directory? path)
+;	     (file-read-access? path))
+;	(let* ((dbpath    (conc path "/spublish.db"))
+;	       (writeable (file-write-access? dbpath))
+;	       (dbexists  (file-exists? dbpath)))
+;	  (handle-exceptions
+;	   exn
+;	   (begin
+;	     (debug:print 2 *default-log-port* "ERROR: problem accessing db " dbpath
+;			  ((condition-property-accessor 'exn 'message) exn))
+;	     (exit 1))
+;	   (call-with-database
+;            dbpath
+;	    (lambda (db)
+;	      ;; (print "calling proc " proc " on db " db)
+;	      (set-busy-handler! db (busy-timeout 10000)) ;; 10 sec timeout
+;	      (if (not dbexists)(spublish:initialize-db db))
+;	      (proc db)))))
+;	(print "ERROR: invalid path for storing database: " path))))
+;
+;;; copy in file to dest, validation is done BEFORE calling this
+;;;
+;(define (spublish:cp configdat submitter source-path target-dir targ-file dest-dir comment)
+;  (let ((dest-dir-path (conc target-dir "/" dest-dir))
+;        (targ-path (conc target-dir "/" dest-dir "/" targ-file)))
+;    (if (file-exists? targ-path)
+;	(begin
+;	  (print "ERROR: target file already exists, remove it before re-publishing")
+;	  (exit 1)))
+;       (if (not(file-exists? dest-dir-path))
+;	(begin
+;	  (print "ERROR: target directory " dest-dir-path " does not exists." )
+;	  (exit 1)))
+;
+;    (spublish:db-do
+;     configdat
+;     (lambda (db)
+;       (spublish:register-action db "cp" submitter source-path comment)))
+;    (let* (;; (target-path (configf:lookup "settings" "target-path"))
+;	   (th1         (make-thread
+;			 (lambda ()
+;			   (file-copy source-path targ-path #t))
+;                            (print " ... file " targ-path " copied to " targ-path)
+;			 ;; (let ((pid (process-run "cp" (list source-path target-dir))))
+;			 ;;   (process-wait pid)))
+;			 "copy thread"))
+;	   (th2         (make-thread
+;			 (lambda ()
+;			   (let loop ()
+;			     (thread-sleep! 15)
+;			     (display ".")
+;			     (flush-output)
+;			     (loop)))
+;			 "action is happening thread")))
+;      (thread-start! th1)
+;      (thread-start! th2)
+;      (thread-join! th1))
+;    (cons #t "Successfully saved data")))
+;
+;;; copy directory to dest, validation is done BEFORE calling this
+;;;
+;
+;(define (spublish:tar configdat submitter target-dir dest-dir comment)
+;  (let ((dest-dir-path (conc target-dir "/" dest-dir)))
+;       (if (not(file-exists? dest-dir-path))
+;	(begin
+;	  (print "ERROR: target directory " dest-dir-path " does not exists." )
+;	  (exit 1)))
+;    ;;(print dest-dir-path )
+;    (spublish:db-do
+;     configdat
+;     (lambda (db)
+;       (spublish:register-action db "tar" submitter dest-dir-path comment)))
+;       (change-directory dest-dir-path)
+;       (process-wait (process-run "/bin/tar" (list "xf" "-")))
+;       (print "Data copied to " dest-dir-path) 
+;
+;        (cons #t "Successfully saved data")))
+
+
+;(define (spublish:validate target-dir targ-mk)
+;  (let* ((normal-path (normalize-pathname targ-mk))
+;        (targ-path (conc target-dir "/" normal-path)))
+;    (if (string-contains   normal-path "..")
+;    (begin
+;      (print "ERROR: Path  " targ-mk " resolved outside target area "  target-dir )
+;      (exit 1)))
+;
+;    (if (not (string-contains targ-path target-dir))
+;    (begin
+;      (print "ERROR: You cannot update data outside " target-dir ".")
+;      (exit 1)))
+;    (print "Path " targ-mk " is valid.")   
+; ))
 ;; make directory in dest
 ;;
 
-(define (spublish:mkdir configdat submitter target-dir targ-mk comment)
-  (let ((targ-path (conc target-dir "/" targ-mk)))
-    
-    (if (file-exists? targ-path)
-	(begin
-	  (print "ERROR: target Directory " targ-path " already exist!!")
-	  (exit 1)))
-    (spublish:db-do
-     configdat
-     (lambda (db)
-       (spublish:register-action db "mkdir" submitter targ-mk comment)))
-    (let* ((th1         (make-thread
-			 (lambda ()
-			   (create-directory targ-path #t)
-			   (print " ... dir " targ-path " created"))
-			 "mkdir thread"))
-	   (th2         (make-thread
-			 (lambda ()
-			   (let loop ()
-			     (thread-sleep! 15)
-			     (display ".")
-			     (flush-output)
-			     (loop)))
-			 "action is happening thread")))
-      (thread-start! th1)
-      (thread-start! th2)
-      (thread-join! th1))
-    (cons #t "Successfully saved data")))
+;(define (spublish:mkdir configdat submitter target-dir targ-mk comment)
+;  (let ((targ-path (conc target-dir "/" targ-mk)))
+;    
+;    (if (file-exists? targ-path)
+;	(begin
+;	  (print "ERROR: target Directory " targ-path " already exist!!")
+;	  (exit 1)))
+;    (spublish:db-do
+;     configdat
+;     (lambda (db)
+;       (spublish:register-action db "mkdir" submitter targ-mk comment)))
+;    (let* ((th1         (make-thread
+;			 (lambda ()
+;			   (create-directory targ-path #t)
+;			   (print " ... dir " targ-path " created"))
+;			 "mkdir thread"))
+;	   (th2         (make-thread
+;			 (lambda ()
+;			   (let loop ()
+;			     (thread-sleep! 15)
+;			     (display ".")
+;			     (flush-output)
+;			     (loop)))
+;			 "action is happening thread")))
+;      (thread-start! th1)
+;      (thread-start! th2)
+;      (thread-join! th1))
+;    (cons #t "Successfully saved data")))
 
 ;; create a symlink in dest
 ;;
-(define (spublish:ln configdat submitter target-dir targ-link link-name comment)
-  (let ((targ-path (conc target-dir "/" link-name)))
-    (if (file-exists? targ-path)
-	(begin
-	  (print "ERROR: target file " targ-path " already exist!!")
-	  (exit 1)))
-     (if (not (file-exists? targ-link ))
-	(begin
-	  (print "ERROR: target file " targ-link " does not exist!!")
-	  (exit 1)))
- 
-    (spublish:db-do
-     configdat
-     (lambda (db)
-       (spublish:register-action db "ln" submitter link-name comment)))
-    (let* ((th1         (make-thread
-			 (lambda ()
-			   (create-symbolic-link targ-link targ-path  )
-			   (print " ... link " targ-path " created"))
-			 "symlink thread"))
-	   (th2         (make-thread
-			 (lambda ()
-			   (let loop ()
-			     (thread-sleep! 15)
-			     (display ".")
-			     (flush-output)
-			     (loop)))
-			 "action is happening thread")))
-      (thread-start! th1)
-      (thread-start! th2)
-      (thread-join! th1))
-    (cons #t "Successfully saved data")))
+;(define (spublish:ln configdat submitter target-dir targ-link link-name comment)
+;  (let ((targ-path (conc target-dir "/" link-name)))
+;    (if (file-exists? targ-path)
+;	(begin
+;	  (print "ERROR: target file " targ-path " already exist!!")
+;	  (exit 1)))
+;     (if (not (file-exists? targ-link ))
+;	(begin
+;	  (print "ERROR: target file " targ-link " does not exist!!")
+;	  (exit 1)))
+; 
+;    (spublish:db-do
+;     configdat
+;     (lambda (db)
+;       (spublish:register-action db "ln" submitter link-name comment)))
+;    (let* ((th1         (make-thread
+;			 (lambda ()
+;			   (create-symbolic-link targ-link targ-path  )
+;			   (print " ... link " targ-path " created"))
+;			 "symlink thread"))
+;	   (th2         (make-thread
+;			 (lambda ()
+;			   (let loop ()
+;			     (thread-sleep! 15)
+;			     (display ".")
+;			     (flush-output)
+;			     (loop)))
+;			 "action is happening thread")))
+;      (thread-start! th1)
+;      (thread-start! th2)
+;      (thread-join! th1))
+;    (cons #t "Successfully saved data")))
 
 
 ;; remove copy of file in dest
 ;;
-(define (spublish:rm configdat submitter target-dir targ-file comment)
-  (let ((targ-path (conc target-dir "/" targ-file)))
-    (if (not (file-exists? targ-path))
-	(begin
-	  (print "ERROR: target file " targ-path " not found, nothing to remove.")
-	  (exit 1)))
-    (spublish:db-do
-     configdat
-     (lambda (db)
-       (spublish:register-action db "rm" submitter targ-file comment)))
-    (let* ((th1         (make-thread
-			 (lambda ()
-			   (delete-file targ-path)
-			   (print " ... file " targ-path " removed"))
-			 "rm thread"))
-	   (th2         (make-thread
-			 (lambda ()
-			   (let loop ()
-			     (thread-sleep! 15)
-			     (display ".")
-			     (flush-output)
-			     (loop)))
-			 "action is happening thread")))
-      (thread-start! th1)
-      (thread-start! th2)
-      (thread-join! th1))
-    (cons #t "Successfully saved data")))
+;(define (spublish:rm configdat submitter target-dir targ-file comment)
+;  (let ((targ-path (conc target-dir "/" targ-file)))
+;    (if (not (file-exists? targ-path))
+;	(begin
+;	  (print "ERROR: target file " targ-path " not found, nothing to remove.")
+;	  (exit 1)))
+;    (spublish:db-do
+;     configdat
+;     (lambda (db)
+;       (spublish:register-action db "rm" submitter targ-file comment)))
+;    (let* ((th1         (make-thread
+;			 (lambda ()
+;			   (delete-file targ-path)
+;			   (print " ... file " targ-path " removed"))
+;			 "rm thread"))
+;	   (th2         (make-thread
+;			 (lambda ()
+;			   (let loop ()
+;			     (thread-sleep! 15)
+;			     (display ".")
+;			     (flush-output)
+;			     (loop)))
+;			 "action is happening thread")))
+;      (thread-start! th1)
+;      (thread-start! th2)
+;      (thread-join! th1))
+;    (cons #t "Successfully saved data")))
 
 (define (spublish:backup-move path)
   (let* ((trashdir  (conc (pathname-directory path) "/.trash"))
 	 (trashfile (conc trashdir "/" (current-seconds) "-" (pathname-file path))))
     (create-directory trashdir #t)
@@ -323,182 +313,476 @@
 
 ;;======================================================================
 ;; MISC
 ;;======================================================================
 
-(define (spublish:do-as-calling-user proc)
-  (let ((eid (current-effective-user-id))
-        (cid (current-user-id)))
-    (if (not (eq? eid cid)) ;; running suid
-            (set! (current-effective-user-id) cid))
-    ;; (print "running as " (current-effective-user-id))
-    (proc)
-    (if (not (eq? eid cid))
-        (set! (current-effective-user-id) eid))))
-
-(define (spublish:find name paths)
-  (if (null? paths)
-      #f
-      (let loop ((hed (car paths))
-		 (tal (cdr paths)))
-	(if (file-exists? (conc hed "/" name))
-	    hed
-	    (if (null? tal)
-		#f
-		(loop (car tal)(cdr tal)))))))
+;(define (spublish:do-as-calling-user proc)
+;  (let ((eid (current-effective-user-id))
+;        (cid (current-user-id)))
+;    (if (not (eq? eid cid)) ;; running suid
+;            (set! (current-effective-user-id) cid))
+;    ;; (print "running as " (current-effective-user-id))
+;    (proc)
+;    (if (not (eq? eid cid))
+;        (set! (current-effective-user-id) eid))))
+
+;(define (spublish:find name paths)
+;  (if (null? paths)
+;      #f
+;      (let loop ((hed (car paths))
+;		 (tal (cdr paths)))
+;	(if (file-exists? (conc hed "/" name))
+;	    hed
+;	    (if (null? tal)
+;		#f
+;		(loop (car tal)(cdr tal)))))))
+
+;;========================================================================
+;;Shell 
+;;========================================================================
+(define (spublish:get-accessable-projects  area)
+   (let* ((projects `()))
+            (if (spublish:has-permission area)
+               (set! projects (cons area projects))
+               (begin
+                 (print "User cannot access area " area "!!")  
+                (exit 1))) 
+    projects))
+
+;; function to find sheets to which use has access 
+(define (spublish:has-permission  area)
+  ;(print "in spublish:has-permission")
+  (let* ((username     (current-user-name))
+        (ret-val #f))
+  (cond
+   ((equal? (is-admin username) #t)
+     (set! ret-val #t))
+    ((equal? (is-user "publish" username area) #t)
+     (set! ret-val #t))
+   ((equal? (is-user "writer-admin" username area) #t) 
+     (set! ret-val #t))
+
+   ((equal? (is-user "area-admin" username area) #t) 
+     (set! ret-val #t))
+   (else  
+    (set! ret-val #f)))
+       ret-val))
+
+(define (is_directory target-path) 
+  (let* ((retval #f))
+  (sauthorize:do-as-calling-user
+    	(lambda ()
+          ;(print (current-effective-user-id) ) 
+          (if (directory? target-path)
+               (set! retval  #t))))
+             ;(print (current-effective-user-id))
+     retval)) 
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; shell functions
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(define (spublish:shell-cp src-path target-path)  
+  (cond
+   ((not (file-exists? target-path))
+	(sauth:print-error (conc " target Directory " target-path " does not exist!!")))
+   ((not (file-exists? src-path))
+    (sauth:print-error (conc "Source path " src-path " does not exist!!" )))
+   (else
+     (if (is_directory src-path) 
+        (begin
+            (let* ((parent-dir src-path)
+                   (start-dir target-path))
+                 (run (pipe
+                   (begin (system (conc "cd " parent-dir " ;tar chf - ." )))
+                   (begin (change-directory start-dir)
+                          ;(print "123")
+                          (run-cmd "tar" (list "xf" "-")))))
+                          (print "Copied data to " start-dir))) 
+        (begin
+           (let*((parent-dir (pathname-directory src-path))
+                  (start-dir target-path)
+                (filename (if  (pathname-extension src-path)  
+                                      (conc(pathname-file src-path) "." (pathname-extension src-path))
+                                      (pathname-file src-path))))
+                ;(print "parent-dir " parent-dir " start-dir " start-dir)   
+                 (run (pipe
+                   (begin (system (conc "cd " parent-dir ";tar chf - " filename )))
+                   (begin (change-directory start-dir)
+                          (run-cmd "tar" (list "xf" "-")))))
+                          (print "Copied data to " start-dir)))))))
+
+
+(define (spublish:shell-mkdir targ-path)
+    (if (file-exists? targ-path)
+	(begin
+	  (print "Info: Target Directory " targ-path " already exist!!"))
+        (let* ((th1         (make-thread
+			 (lambda ()
+			   (create-directory targ-path #t)
+			   (print " ... dir " targ-path " created"))
+			 "mkdir thread"))
+	   (th2         (make-thread
+			 (lambda ()
+			   (let loop ()
+			     (thread-sleep! 15)
+			     (display ".")
+			     (flush-output)
+			     (loop)))
+			 "action is happening thread")))
+      (thread-start! th1)
+      (thread-start! th2)
+      (thread-join! th1)
+    (cons #t "Successfully saved data"))))
+ 
+
+(define (spublish:shell-rm targ-path iport)
+    (if (not (file-exists? targ-path))
+	(begin
+	  (sauth:print-error (conc "target path " targ-path " does not exist!!")))
+        (begin 
+           (print "Are you sure you want to delete " targ-path "?[y/n]") 
+            (let* ((inl (read-line iport)))
+                (if (equal? inl "y")
+	             (let* ((th1         (make-thread
+			     (lambda ()
+                                (if (symbolic-link? targ-path)
+                                  (delete-file  targ-path )  
+                                  (if (directory? targ-path)
+                                    (delete-directory targ-path #t)     
+			            (delete-file  targ-path )))
+			        (print " ... path " targ-path " deleted"))
+			        "rm thread"))
+	   		    (th2         (make-thread
+			      (lambda ()
+			         (let loop ()
+			            (thread-sleep! 15)
+			            (display ".")
+			            (flush-output)
+			            (loop)))
+			 "action is happening thread")))
+      			(thread-start! th1)
+      			(thread-start! th2)
+      			(thread-join! th1)
+    			(cons #t "Successfully saved data")))))))
+
+(define (spublish:shell-ln src-path target-path sub-path)
+   (if (not (file-exists? sub-path))
+	 (sauth:print-error (conc "Path " sub-path " does not exist!! cannot proceed with link creation!!"))
+        (begin  
+          (if (not (file-exists? src-path))
+  	    (sauth:print-error (conc "Path " src-path " does not exist!! cannot proceed with link creation!!"))
+            (begin
+                (if (file-exists? target-path)
+                   (sauth:print-error (conc "Path " target-path "already exist!! cannot proceed with link creation!!"))
+                   (begin 
+                      (create-symbolic-link src-path target-path  )
+			   (print " ... link " target-path " created"))))))))
+ 
+(define (spublish:shell-help)
+(conc "Usage: [action [params ...]]
+
+  ls    [target path]               	  : list contents of target area.
+  cd     	     	          : To change the current directory within the sretrive shell. 
+  pwd				     	  : Prints the full pathname of the current directory within the sretrive shell.
+  mkdir                             : creates directory. Note it does not create's a path recursive manner.
+  rm                         : removes files and emoty directories   
+  cp                    : copy a file/dir to target path. if src is a dir it automatically makes a recursive copy.
+  ln TARGET LINK_NAME                     : creates a symlink      
+Part of the Megatest tool suite.
+Learn more at http://www.kiatoa.com/fossils/megatest
+
+Version: " megatest-fossil-hash)
+)	
+
+(define (toplevel-command . args) #f)
+
+(define (spublish:shell area)
+ ; (print area)
+  (use readline)
+
+  (let* ((path      '())
+	 (prompt    "spublish> ")
+	 (args      (argv))
+         (usr (current-user-name) )   
+         (top-areas (spublish:get-accessable-projects area))
+         (close-port     #f)
+         (area-obj  (get-obj-by-code area))
+         (user-obj (get-user usr)) 
+         (base-path (if (null? area-obj) 
+                         "" 
+                        (caddr (cdr area-obj))))      
+	 (iport     (make-readline-port prompt)))
+        ;(print base-path) 
+        (if (null? area-obj)
+          (begin 
+             (print "Area " area " does not exist")
+          (exit 1)))
+        ; (print "here")    
+	(let loop ((inl (read-line iport)))
+	  (if (not (or (or (eof-object? inl)
+		       (equal? inl "exit")) (port-closed? iport)))
+	      (let* ((parts (string-split inl))
+		     (cmd   (if (null? parts) #f (car parts))))
+		(if (and (not cmd) (not (port-closed? iport)))
+		    (loop (read-line))
+		    (case (string->symbol cmd)
+		      ((cd)
+		       (if (> (length parts) 1) ;; have a parameter
+                           (begin
+                             (let*((arg (cadr parts))
+                                   (resolved-path (sauth-common:resolve-path  arg path top-areas))
+                                   (target-path (sauth-common:get-target-path path  arg top-areas base-path)))
+                                 (if (not (equal? target-path #f))
+                                 (if (or (equal? resolved-path #f) (not (file-exists? target-path)))    
+                                 (print "Invalid argument " arg ".. ")
+                                  (begin      
+			            (set! path resolved-path)
+                                     (sauthorize:do-as-calling-user
+                              (lambda ()
+			    (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "\"" inl "\"") (number->string (car user-obj))  (number->string (caddr area-obj))  "cd"))))
+                                  )))))  
+   			   (set! path '())))
+                      ((pwd)
+                         (if (null? path)
+                           (print "/")  
+                           (print "/" (string-join path "/")))) 
+		      ((ls)
+		       (let* ((thepath (if (> (length parts) 1) ;; have a parameter
+					   (cdr parts)
+					   `()))
+			      (plen    (length thepath)))
+                         (cond
+			  ((null? thepath)
+                           (sauth-common:shell-ls-cmd path "" top-areas base-path  '())
+                            (sauthorize:do-as-calling-user
+                              (lambda ()
+			    (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "\"" inl "\"") (number->string (car user-obj))  (number->string (caddr area-obj))  "ls"))))   )
+			  ((< plen 2)
+                            (sauth-common:shell-ls-cmd path  (car thepath) top-areas base-path '())
+                              (sauthorize:do-as-calling-user
+                              (lambda ()
+			    (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "\"" inl "\"") (number->string (car user-obj))  (number->string (caddr area-obj))  "ls")))))
+                          (else 
+                            (if (equal? (car thepath) "|")
+                              (sauth-common:shell-ls-cmd path "" top-areas base-path thepath)
+                              (sauth-common:shell-ls-cmd path  (car thepath) top-areas base-path (cdr thepath)))
+                           (sauthorize:do-as-calling-user
+                              (lambda ()
+			    (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "\"" inl "\"") (number->string (car user-obj))  (number->string (caddr area-obj))  "ls"))))))))
+                       ((mkdir)
+                         (let* ((thepath (if (> (length parts) 1) ;; have a parameter
+				   (cdr parts)
+				   `()))
+			      (plen    (length thepath)))
+                         (cond
+                          ((null? thepath)
+                            (print "mkdir takes one argument"))
+                          ((< plen 2) 
+                            (let*((mk-path (cadr parts))
+                                  (resolved-path (sauth-common:resolve-path  mk-path path top-areas))
+                                  (target-path (sauth-common:get-target-path path  mk-path top-areas base-path)))
+                              (if (not (equal? target-path #f))
+                                 (if (equal? resolved-path #f)     
+                                 (print "Invalid argument " mk-path ".. ")
+                                  (begin 
+                                       (print "here")
+                                      (spublish:shell-mkdir target-path)   
+                                      (sauthorize:do-as-calling-user
+                              (lambda ()
+			    (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "\"" inl "\"") (number->string (car user-obj))  (number->string (caddr area-obj))  "mkdir")))))))
+		       )))))
+                       ((rm)
+                          (let* ((thepath (if (> (length parts) 1) ;; have a parameter
+				   (cdr parts)
+				   `()))
+			      (plen    (length thepath)))
+                         (cond
+                          ((null? thepath)
+                            (print "rm takes one argument"))
+                          ((< plen 2) 
+                            (let*((rm-path (cadr parts))
+                                  (resolved-path (sauth-common:resolve-path  rm-path path top-areas))
+                                  (target-path (sauth-common:get-target-path path  rm-path top-areas base-path)))
+                              (if (not (equal? target-path #f))
+                                 (if (equal? resolved-path #f)     
+                                 (print "Invalid argument " rm-path ".. ")
+                                  (begin 
+                                      (spublish:shell-rm target-path iport)   
+                                      (sauthorize:do-as-calling-user
+                              (lambda ()
+			    (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "\"" inl "\"") (number->string (car user-obj))  (number->string (caddr area-obj))  "rm")))))))
+		       )))))
+
+                      ((cp publish)
+                          (let* ((thepath (if (> (length parts) 1) ;; have a parameter
+				   (cdr parts)
+				   `()))
+			      (plen    (length thepath)))
+                         (cond
+                          ((or (null? thepath) (< plen 2)) 
+                            (print "cp takes two argument"))
+                          ((< plen 3) 
+                            (let*((src-path (car thepath))
+                                  (dest-path (cadr thepath))   
+                                  (resolved-path (sauth-common:resolve-path  dest-path path top-areas))
+                                  (target-path (sauth-common:get-target-path path  dest-path top-areas base-path)))
+                              (if (not (equal? target-path #f))
+                                 (if (equal? resolved-path #f)     
+                                 (print "Invalid argument " dest-path ".. ")
+                                  (begin 
+                                      (spublish:shell-cp src-path target-path)   
+                                      (sauthorize:do-as-calling-user
+                              (lambda ()
+			    (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "\"" inl "\"") (number->string (car user-obj))  (number->string (caddr area-obj))  "cp")))))))
+		       )))))
+                      ((ln)
+                           (let* ((thepath (if (> (length parts) 1) ;; have a parameter
+				   (cdr parts)
+				   `()))
+			      (plen    (length thepath)))
+                         (cond
+                          ((or (null? thepath) (< plen 2)) 
+                            (print "ln takes two argument"))
+                          ((< plen 3) 
+                            (let*((src-path (car thepath))
+                                  (dest-path (cadr thepath))   
+                                  (resolved-path (sauth-common:resolve-path  dest-path path top-areas))
+                                  (target-path (sauth-common:get-target-path path  dest-path top-areas base-path))
+                                  (sub-path (conc "/" (string-reverse (string-join (cdr (string-split (string-reverse  target-path) "/")) "/")))))
+                              (if (not (equal? target-path #f))
+                                 (if (equal? resolved-path #f)     
+                                 (print "Invalid argument " dest-path ".. ")
+                                  (begin 
+                                      (spublish:shell-ln src-path target-path sub-path)   
+                                      (sauthorize:do-as-calling-user
+                              (lambda ()
+			    (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "\"" inl "\"") (number->string (car user-obj))  (number->string (caddr area-obj))  "ln")))))))
+		       )))))  
+                      ((exit)
+                          (print "got exit"))  
+                      ((help)
+                          (print (spublish:shell-help)))
+		      (else 
+		       (print "Got command: " inl))))
+                 (loop (read-line iport)))))))
+
 
 ;;======================================================================
 ;; MAIN
 ;;======================================================================
 
-(define (spublish:load-config exe-dir exe-name)
-  (let* ((fname   (conc exe-dir "/." exe-name ".config")))
+;(define (spublish: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)
-	;; (ini:read-ini fname)
-	(read-config fname #f #t)
-	(make-hash-table))))
-
-(define (spublish:process-action configdat action . args)
-  (let* ((target-dir    (configf:lookup configdat "settings" "target-dir"))
-	 (user          (current-user-name))
-	 (allowed-users (string-split
-			 (or (configf:lookup configdat "settings" "allowed-users")
-			     ""))))
-    (if (not target-dir)
-	(begin
-	  (print "[settings]\ntarget-dir /some/path\n\n Is MISSING from the config file!")
-	  (exit)))
-    (if (null? allowed-users)
-	(begin
-	  (print "[setings]\nallowed-users user1 user2 ...\n\n Is MISSING from the config file!")
-	  (exit)))
-    (if (not (member user allowed-users))
-	(begin
-	  (print "User \"" (current-user-name) "\" does not have access. Exiting")
-	  (exit 1)))
+;    (if (file-exists? fname)
+;	;; (ini:read-ini fname)
+;	(read-config fname #f #t)
+;	(make-hash-table))))
+
+(define (spublish:process-action action . args)
+  ;(print args)
+  (let* ((usr          (current-user-name))
+         (user-obj (get-user usr)) 
+         (area   (car args))
+         (area-obj  (get-obj-by-code area))
+         (top-areas (spublish:get-accessable-projects area))  
+         (base-path (if (null? area-obj) 
+                         "" 
+                        (caddr (cdr area-obj))))   
+         (remargs (cdr args)))
+     (if (null? area-obj)
+          (begin 
+             (print "Area " area " does not exist")
+          (exit 1)))
     (case (string->symbol action)
       ((cp publish)
-       (if (< (length args) 2)
+       (if (< (length remargs) 2)
 	   (begin 
-	     (print "ERROR: Missing arguments; " (string-intersperse args ", "))
+	     (print "ERROR: Missing arguments; spublish   " )
 	     (exit 1)))
-       (let* ((remargs     (args:get-args args '("-m") '() args:arg-hash 0))
-              (dest-dir (cadr args))
-              (src-path-in (car args))
+       (let* ((filter-args     (args:get-args args '("-m") '() args:arg-hash 0))
+              (src-path-in (car filter-args))
+              (dest-path (cadr filter-args))
 	      (src-path    (with-input-from-pipe
 			    (conc "readlink -f " src-path-in)
 			    (lambda ()
 			      (read-line))))
 	      (msg         (or (args:get-arg "-m") ""))
-	      (targ-file   (pathname-strip-directory src-path)))
-	 (if (not (file-read-access? src-path))
-	     (begin
-	       (print "ERROR: source file not readable: " src-path)
-	       (exit 1)))
-	 (if (directory? src-path)
-	     (begin
-              (print "ERROR: source file is a directory, this is not supported yet.")
-	       (exit 1)))
-	     (print "publishing " src-path-in " to " target-dir)
-             (spublish:validate     target-dir dest-dir)
-	     (spublish:cp configdat user src-path target-dir targ-file dest-dir msg)))
-      ((tar)
-        (if (< (length args) 1)
-          (begin 
-	     (print "ERROR: Missing arguments; " (string-intersperse args ", "))
-	     (exit 1)))
-        (let* ((dst-dir (car args))
-               (msg         (or (args:get-arg "-m") "")))
-               (spublish:validate     target-dir  dst-dir)
-               (spublish:tar configdat user target-dir dst-dir msg)))
- 
-      ((mkdir)
-        (if (< (length args) 1)
-          (begin 
-	     (print "ERROR: Missing arguments; " (string-intersperse args ", "))
-	     (exit 1)))
-        (let* ((targ-mk (car args))
-               (msg         (or (args:get-arg "-m") ""))) 
-               (print "attempting to create directory " targ-mk " in " target-dir)
-               (spublish:validate     target-dir targ-mk)
-               (spublish:mkdir configdat user target-dir targ-mk msg)))
-
-      ((ln) 
-        (if (< (length args) 2)
-          (begin 
-	     (print "ERROR: Missing arguments; " (string-intersperse args ", "))
-	     (exit 1)))
-        (let* ((targ-link (car args))
-               (link-name (cadr args))  
-               (sub-path (string-reverse (string-join (cdr (string-split (string-reverse link-name) "/")) "/"))) 
-               (msg         (or (args:get-arg "-m") "")))
-               (if (> (string-length(string-trim sub-path)) 0)
-                (begin 
-                  (print "attempting to create directory " sub-path " in " target-dir)
-                  (spublish:validate     target-dir sub-path)
-                  (print (conc target-dir "/" sub-path ) )
-                  (print (directory-exists?(conc target-dir "/" sub-path )))
-                  (if (directory-exists?(conc target-dir "/" sub-path ))
-                   (print "Target Directory " (conc target-dir sub-path ) " exist!!")
-                  (spublish:mkdir configdat user target-dir sub-path msg))))
-
-               (print "attempting to create link " link-name " in " target-dir)
-               (spublish:ln configdat user target-dir targ-link link-name msg)))
-
+              (resolved-path (sauth-common:resolve-path  (conc area "/" dest-path) `() top-areas))
+              (target-path (sauth-common:get-target-path `()  (conc area "/" dest-path) top-areas base-path)))
+ 	     (if (not (equal? target-path #f))
+                 (if (equal? resolved-path #f)     
+                    (print "Invalid argument " dest-path ".. ")
+                    (begin 
+                      (spublish:shell-cp src-path target-path)   
+                      (sauthorize:do-as-calling-user
+                      (lambda ()
+		        (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "\" cp " src-path-in " " dest-path  "\"") (number->string (car user-obj))  (number->string (caddr area-obj))  "cp")))))))))   
+      ((mkdir)
+        (if (< (length remargs) 1)
+          (begin 
+	     (print "ERROR: Missing arguments;  ")
+	     (exit 1)))
+        (let* ((filter-args     (args:get-args args '("-m") '() args:arg-hash 0))
+               (mk-path (car filter-args))
+               (msg         (or (args:get-arg "-m") ""))
+               (resolved-path (sauth-common:resolve-path  mk-path (list area) top-areas))
+               (target-path (sauth-common:get-target-path (list area)  mk-path top-areas base-path))) 
+               (print "attempting to create directory " mk-path  )
+               (if (not (equal? target-path #f))
+                 (if (equal? resolved-path #f)     
+                   (print "Invalid argument " mk-path ".. ")
+                   (begin 
+                     (spublish:shell-mkdir target-path)   
+                     (sauthorize:do-as-calling-user
+                       (lambda ()
+		        (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "\" mkdir " mk-path  "\"") (number->string (car user-obj))  (number->string (caddr area-obj))  "mkdir")))))))))  
+      ((ln) 
+        (if (< (length remargs) 2)
+          (begin 
+	     (print "ERROR: Missing arguments;    " )
+	     (exit 1)))
+        (let* ((filter-args     (args:get-args args '("-m") '() args:arg-hash 0))
+              (src-path (car filter-args))
+              (dest-path (cadr filter-args))   
+              (resolved-path (sauth-common:resolve-path  dest-path (list area) top-areas))
+              (target-path (sauth-common:get-target-path  (list area)  dest-path top-areas base-path))
+              (sub-path (conc "/" (string-reverse (string-join (cdr (string-split (string-reverse  target-path) "/")) "/")))))
+               (if (not (equal? target-path #f))
+                  (if (equal? resolved-path #f)     
+                    (print "Invalid argument " dest-path ".. ")
+                    (begin 
+                   (spublish:shell-ln src-path target-path sub-path)   
+                  (sauthorize:do-as-calling-user
+                 (lambda ()
+		   (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "\" ln " src-path " " dest-path  "\"") (number->string (car user-obj))  (number->string (caddr area-obj))  "ln")))))))))
       ((rm)
-       (if (< (length args) 1)
+       (if (< (length remargs) 1)
 	   (begin 
-	     (print "ERROR: Missing arguments; " (string-intersperse args ", "))
+	     (print "ERROR: Missing arguments;   ")
 	     (exit 1)))
-       (let* ((targ-file (car args))
-	      (msg         (or (args:get-arg "-m") "")))
-	 (print "attempting to remove " targ-file " from " target-dir)
-           (spublish:validate     target-dir targ-file)
-
-	 (spublish:rm configdat user target-dir targ-file msg)))
-      ((publish)
-       (if (< (length args) 3)
-	   (begin 
-	     (print "ERROR: Missing arguments; " (string-intersperse args ", "))
+       (let* ((filter-args  (args:get-args args '("-m") '() args:arg-hash 0))
+              (rm-path (car filter-args))
+              (resolved-path (sauth-common:resolve-path  rm-path (list area) top-areas))
+               (prompt    ">")
+              (iport     (make-readline-port prompt))
+              (target-path (sauth-common:get-target-path (list area)  rm-path top-areas base-path)))
+	       (if (not (equal? target-path #f))
+                                 (if (equal? resolved-path #f)     
+                                 (print "Invalid argument " rm-path ".. ")
+                                  (begin 
+                                      (spublish:shell-rm target-path iport)   
+                                      (sauthorize:do-as-calling-user
+                              (lambda ()
+			    (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "\" rm " rm-path "\"") (number->string (car user-obj))  (number->string (caddr area-obj))  "rm")))))))))
+      ((shell)
+          (if (< (length args) 1)
+             (begin 
+	     (print  "ERROR: Missing arguments area!!" )
 	     (exit 1))
-	   (let* ((srcpath  (list-ref args 0))
-		  (areaname (list-ref args 1))
-		  (version  (list-ref args 2))
-		  (remargs  (args:get-args (drop args 2)
-					   '("-type" ;; link or copy (default is copy)
-					     "-m")
-					   '()
-					   args:arg-hash
-					   0))
-		  (publish-type (if (equal? (args:get-arg "-type") "link") 'link 'copy))
-		  (comment      (or (args:get-arg "-m") ""))
-		  (submitter    (current-user-name))
-		  (quality      (args:get-arg "-quality"))
-		  (publish-res  (spublish:publish configdat publish-type areaname version comment srcpath submitter quality)))
-	     (if (not (car publish-res))
-		 (begin
-		   (print "ERROR: " (cdr publish-res))
-		   (exit 1))))))
-      ((list-versions)
-       (let ((area-name (car args)) ;;      version patt   full print
-	     (remargs   (args:get-args args '("-vpatt") '("-full") args:arg-hash 0))
-	     (db        (spublish:open-db configdat))
-	     (versions  (spublish:get-versions-for-area db (car args) version-patt: (args:get-arg "-vpatt"))))
-	 ;; (print "area-name=" area-name " args=" args " *args-hash*=" (hash-table->alist *args-hash*))
-	 (map (lambda (x)
-		(if (args:get-arg "-full")
-		    (format #t 
-			    "~10a~10a~4a~27a~30a\n"
-			    (vector-ref x 0)
-			    (vector-ref x 1) 
-			    (vector-ref x 2) 
-			    (conc "\"" (time->string (seconds->local-time (vector-ref x 3))) "\"")
-			    (conc "\"" (vector-ref x 4) "\""))
-		    (print (vector-ref x 0))))
-	      versions)))
+             (spublish:shell area))) 
       (else (print "Unrecognised command " action)))))
   
 ;; ease debugging by loading ~/.dashboardrc - REMOVE FROM PRODUCTION!
 ;; (let ((debugcontrolf (conc (get-environment-variable "HOME") "/.spublishrc")))
 ;;   (if (file-exists? debugcontrolf)
@@ -506,37 +790,21 @@
 
 (define (main)
   (let* ((args      (argv))
 	 (prog      (car args))
 	 (rema      (cdr args))
-	 (exe-name  (pathname-file (car (argv))))
-	 (exe-dir   (or (pathname-directory prog)
-			(spublish:find exe-name (string-split (get-environment-variable "PATH") ":"))))
-	 (configdat (spublish:load-config exe-dir exe-name)))
+	 (exe-name  (pathname-file (car (argv)))))
     (cond
      ;; one-word commands
      ((eq? (length rema) 1)
       (case (string->symbol (car rema))
 	((help -h -help --h --help)
 	 (print spublish:help))
-	((list-vars) ;; print out the ini file
-	 (map print (spublish:get-areas configdat)))
-	((ls)
-	 (let ((target-dir (configf:lookup configdat "settings" "target-dir")))
-	   (print "Files in " target-dir)
-	   (system (conc "ls " target-dir))))
-	((log)
-	 (spublish:db-do configdat (lambda (db)
-				     (print "Listing actions")
-				     (query (for-each-row
-					     (lambda (row)
-					       (apply print (intersperse row " | "))))
-					    (sql db "SELECT * FROM actions")))))
 	(else
 	 (print "ERROR: Unrecognised command. Try \"spublish help\""))))
      ;; multi-word commands
      ((null? rema)(print spublish:help))
      ((>= (length rema) 2)
-      (apply spublish:process-action configdat (car rema)(cdr rema)))
+      (apply spublish:process-action (car rema)(cdr rema)))
      (else (print "ERROR: Unrecognised command2. Try \"spublish help\"")))))
 
 (main)

Index: sretrieve.scm
==================================================================
--- sretrieve.scm
+++ sretrieve.scm
@@ -1,49 +1,44 @@
 
 ;; 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 defstruct)
-
-;; (use ssax)
-;; (use sxml-serializer)
-;; (use sxml-modifications)
-;; (use regex)
-;; (use srfi-69)
-;; (use regex-case)
-;; (use posix)
-;; (use json)
-;; (use csv)
-;; (use directory-utils)
+(use scsh-process)
 (use srfi-18)
-(use format)
-
-;; (require-library ini-file)
-;; (import (prefix ini-file ini:))
-
+(use srfi-19)
+(use refdb)
 (use sql-de-lite srfi-1 posix regex regex-case srfi-69)
-;; (import (prefix sqlite3 sqlite3:))
-;; 
+(declare (uses common))
 (declare (uses configf))
-;; (declare (uses tree))
 (declare (uses margs))
-;; (declare (uses dcommon))
-;; (declare (uses launch))
-;; (declare (uses gutils))
-;; (declare (uses db))
-;; (declare (uses synchash))
-;; (declare (uses server))
 (declare (uses megatest-version))
-;; (declare (uses tbd))
+ 
 
 (include "megatest-fossil-hash.scm")
+;;; please create this file before using sautherise. For sample file is avaliable sample-sauth-paths.scm. 
+(include "sauth-paths.scm")
+(include "sauth-common.scm")
+
+(define (toplevel-command . args) #f)
+(use readline)
+
 
 ;;
 ;; GLOBALS
 ;;
 (define *verbosity* 1)
@@ -51,16 +46,14 @@
 (define *exe-name* (pathname-file (car (argv))))
 (define *sretrieve:current-tab-number* 0)
 (define *args-hash* (make-hash-table))
 (define sretrieve:help (conc "Usage: " *exe-name* " [action [params ...]]
 
-  ls                     : list contents of target area
-  get        : retrieve data for release 
-    -m \"message\"       : why retrieved?
-  cp      : copy file to current directory 
-  log                    : get listing of recent downloads
-  shell                  : start a shell-like interface
+  ls                           : list contents of target area
+  get           : retrieve path to the data within 
+     -m \"message\"       : why retrieved?
+  shell                     : start a shell-like interface
 
 Part of the Megatest tool suite.
 Learn more at http://www.kiatoa.com/fossils/megatest
 
 Version: " megatest-fossil-hash)) ;; "
@@ -72,320 +65,214 @@
 ;;======================================================================
 ;; DB
 ;;======================================================================
 
 ;; replace (strftime('%s','now')), with datetime('now'))
-(define (sretrieve:initialize-db db)
-  (for-each
-   (lambda (qry)
-     (exec (sql db qry)))
-   (list 
-    "CREATE TABLE IF NOT EXISTS actions
-         (id           INTEGER PRIMARY KEY,
-          action       TEXT NOT NULL,
-          retriever    TEXT NOT NULL,
-          datetime     TIMESTAMP DEFAULT (datetime('now','localtime')),
-          srcpath      TEXT NOT NULL,
-          comment      TEXT DEFAULT '' NOT NULL,
-          state        TEXT DEFAULT 'new');"
-    "CREATE TABLE IF NOT EXISTS bundles
-         (id           INTEGER PRIMARY KEY,
-          bundle       TEXT NOT NULL,
-          release      TEXT NOT NULL,
-          status       TEXT NOT NULL,
-          event_date   TEXT NOT NULL);"
-    )))
-
-(define (sretrieve:register-action db action submitter source-path comment)
-  (print "(sretrieve:register-action db " db " action " action " submitter " submitter " source-path " source-path " comment " comment)
-  (exec (sql db "INSERT INTO actions (action,retriever,srcpath,comment)
-                 VALUES(?,?,?,?)")
-	action
-	submitter
-	source-path
-	(or comment "")))
+;(define (sretrieve:initialize-db db)
+;  (for-each
+;   (lambda (qry)
+;     (exec (sql db qry)))
+;   (list 
+;    "CREATE TABLE IF NOT EXISTS actions
+;         (id           INTEGER PRIMARY KEY,
+;          action       TEXT NOT NULL,
+;          retriever    TEXT NOT NULL,
+;          datetime     TIMESTAMP DEFAULT (datetime('now','localtime')),
+;          srcpath      TEXT NOT NULL,
+;          comment      TEXT DEFAULT '' NOT NULL,
+;          state        TEXT DEFAULT 'new');"
+;    "CREATE TABLE IF NOT EXISTS bundles
+;         (id           INTEGER PRIMARY KEY,
+;          bundle       TEXT NOT NULL,
+;          release      TEXT NOT NULL,
+;          status       TEXT NOT NULL,
+;          event_date   TEXT NOT NULL);"
+;    )))
+;
+;(define (sretrieve:register-action db action submitter source-path comment)
+; ; (print "(sretrieve:register-action db " db " action " action " submitter " submitter " source-path " source-path " comment " comment)
+;  (exec (sql db "INSERT INTO actions (action,retriever,srcpath,comment)
+;                 VALUES(?,?,?,?)")
+;	action
+;	submitter
+;	source-path
+;	(or comment "")))
 
 ;; (call-with-database
 ;;  (lambda (db)
 ;;   (set-busy-handler! db (busy-timeout 10000)) ; 10 second timeout
 ;;   ...))
 
 ;; Create the sqlite db
-(define (sretrieve:db-do configdat proc) 
-
-  (let ((path (configf:lookup configdat "database" "location")))
-    (if (not path)
-	(begin
-	  (debug:print 0 *default-log-port* "[database]\nlocation /some/path\n\n Is missing from the config file!")
-	  (exit 1)))
-    (if (and path
-	     (directory? path)
-	     (file-read-access? path))
-	(let* ((dbpath    (conc path "/" *exe-name* ".db"))
-	       (writeable (file-write-access? dbpath))
-	       (dbexists  (file-exists? dbpath)))
-	  (handle-exceptions
-	   exn
-	   (begin
-	     (debug:print 2 *default-log-port* "ERROR: problem accessing db " dbpath
-			  ((condition-property-accessor 'exn 'message) exn))
-	     (exit 1))
-            ;;(debug:print 0 *default-log-port* "calling proc " proc "db path " dbpath )
-	   (call-with-database
-            dbpath
-	    (lambda (db)
-	       ;;(debug:print 0 *default-log-port* "calling proc " proc " on db " db)
-	      (set-busy-handler! db (busy-timeout 10000)) ;; 10 sec timeout
-	      (if (not dbexists)(sretrieve:initialize-db db))
-	      (proc db)))))
-	(debug:print-error 0 *default-log-port* "invalid path for storing database: " path))))
+;(define (sretrieve:db-do configdat proc) 
+;  (let ((path (configf:lookup configdat "database" "location")))
+;    (if (not path)
+;	(begin
+;	  (debug:print 0 "[database]\nlocation /some/path\n\n Is missing from the config file!")
+;	  (exit 1)))
+;    (if (and path
+;	     (directory? path)
+;	     (file-read-access? path))
+;	(let* ((dbpath    (conc path "/" *exe-name* ".db"))
+;	       (writeable (file-write-access? dbpath))
+;	       (dbexists  (file-exists? dbpath)))
+;	  (handle-exceptions
+;	   exn
+;	   (begin
+;	     (debug:print 2 "ERROR: problem accessing db " dbpath
+;			  ((condition-property-accessor 'exn 'message) exn))
+;	     (exit 1))
+;            ;;(debug:print 0 "calling proc " proc "db path " dbpath )
+;	   (call-with-database
+;            dbpath
+;	    (lambda (db)
+;	       ;;(debug:print 0 "calling proc " proc " on db " db)
+;	      (set-busy-handler! db (busy-timeout 10000)) ;; 10 sec timeout
+;	      (if (not dbexists)(sretrieve:initialize-db db))
+;	      (proc db)))))
+;	(debug:print 0 "ERROR: invalid path for storing database: " path))))
 
 ;; copy in directory to dest, validation is done BEFORE calling this
 ;;
-(define (sretrieve:get configdat retriever version comment)
-  (let* ((base-dir  (configf:lookup configdat "settings" "base-dir"))
-	 (datadir   (conc base-dir "/" version)))
-    (if (or (not base-dir)
-	    (not (file-exists? base-dir)))
-	(begin
-	  (debug:print-error 0 *default-log-port* "Bad configuration! base-dir " base-dir " not found")
-	  (exit 1)))
-    (print datadir)
-    (if (not (file-exists? datadir))
-	(begin
-	  (debug:print-error 0 *default-log-port* "Bad version (" version "), no data found at " datadir "." )
-	  (exit 1)))
-    
-    (sretrieve:db-do
-     configdat
-     (lambda (db)
-       (sretrieve:register-action db "get" retriever datadir comment)))
-      (sretrieve:do-as-calling-user
-       (lambda ()
-         (if (directory? datadir)
-	   (begin
-  	    (change-directory datadir)
-	    (let ((files (filter (lambda (x)
-				(not (member x '("." ".."))))
-			      (glob "*" ".*"))))
-	     (print "files: " files)
-	     (process-execute "/bin/tar" (append (append (list  "chfv" "-") files) (list "--ignore-failed-read")))))
-             (begin
-               (let* ((parent-dir (pathname-directory datadir) )
-                      (filename  (conc(pathname-file datadir) "." (pathname-extension datadir))))
-                  (change-directory parent-dir)  
-                  (process-execute "/bin/tar" (list "chfv" "-" filename))
-             )))
-))
-))
-
-
-;; copy in file to dest, validation is done BEFORE calling this
-;;
-(define (sretrieve:cp configdat retriever file comment)
-  (let* ((base-dir  (configf:lookup configdat "settings" "base-dir"))
-         (allowed-sub-paths (configf:lookup configdat "settings" "allowed-sub-paths"))    
-	 (datadir   (conc base-dir "/" file))
-         (filename  (conc(pathname-file datadir) "." (pathname-extension datadir))))
-    (if (or (not base-dir)
-	    (not (file-exists? base-dir)))
-	(begin
-	  (debug:print-error 0 *default-log-port* "Bad configuration! base-dir " base-dir " not found")
-	  (exit 1)))
-    (print datadir)
-    (if (not (file-exists? datadir))
-	(begin
-	  (debug:print-error 0 *default-log-port* "File  (" file "), not found at " base-dir "." )
-	  (exit 1)))
-    (if (directory? datadir)
-	(begin
-	  (debug:print-error 0 *default-log-port* "(" file ") is a dirctory!! cp cmd works only on files ." )
-	  (exit 1)))
-    (if(not (string-match (regexp  allowed-sub-paths) file))
-        (begin
-	  (debug:print-error 0 *default-log-port* "Access denied to file (" file ")!! " )
-	  (exit 1)))
-     
-     (sretrieve:db-do
-     configdat
-     (lambda (db)
-       (sretrieve:register-action db "cp" retriever datadir comment)))
-      (sretrieve:do-as-calling-user
-      ;;  (debug:print 0 *default-log-port* "ph:  "(pathname-directory datadir)  "!! " )
-       (change-directory (pathname-directory datadir))  
-       ;;(debug:print 0 *default-log-port* "ph: /bin/tar" (list "chfv" "-" filename) )
-      (process-execute "/bin/tar" (list "chfv" "-" filename)))
-      ))
-
-;; ls in file to dest, validation is done BEFORE calling this
-;;
-(define (sretrieve:ls configdat retriever file comment)
-  (let* ((base-dir  (configf:lookup configdat "settings" "base-dir"))
-         (allowed-sub-paths (configf:lookup configdat "settings" "allowed-sub-paths"))    
-	 (datadir   (conc base-dir "/" file))
-         (filename  (conc(pathname-file datadir) "." (pathname-extension datadir))))
-    (if (or (not base-dir)
-	    (not (file-exists? base-dir)))
-	(begin
-	  (debug:print-error 0 *default-log-port* "Bad configuration! base-dir " base-dir " not found")
-	  (exit 1)))
-    (print datadir)
-    (if (not (file-exists? datadir))
-	(begin
-	  (debug:print-error 0 *default-log-port* "File  (" file "), not found at " base-dir "." )
-	  (exit 1)))
-      (if(not (string-match (regexp  allowed-sub-paths) file))
-        (begin
-	  (debug:print-error 0 *default-log-port* "Access denied to file (" file ")!! " )
-	  (exit 1)))
-   
-        (sretrieve:do-as-calling-user
-        (lambda ()
-	 ;;(change-directory datadir)
-         ;; (debug:print 0 *default-log-port*  "/usr/bin/find" (list datadir "-ls" "|" "grep" "-E" "'"allowed-file-patt"'"))
-         ;; (status (with-input-from-pipe "find " datadir " -ls | grep -E '" allowed-file-patt "'" (lambda () (read-line))))
-         ;; (debug:print 0 *default-log-port* status) 
-	  (process-execute "/bin/ls" (list "-ls"  "-lrt" datadir ))
- ))))
-
-
-
-;;(filter (lambda (x)
-;;							     (not (member x '("." ".."))))
-;;							   (glob "*" ".*"))))))))
+;(define (sretrieve:get configdat retriever version comment)
+;  (let* ((base-dir  (configf:lookup configdat "settings" "base-dir"))
+;	 (datadir   (conc base-dir "/" version)))
+;    (if (or (not base-dir)
+;	    (not (file-exists? base-dir)))
+;	(begin
+;	  (debug:print 0 "ERROR: Bad configuration! base-dir " base-dir " not found")
+;	  (exit 1)))
+;    (print datadir)
+;    (if (not (file-exists? datadir))
+;	(begin
+;	  (debug:print 0 "ERROR: Bad version (" version "), no data found at " datadir "." )
+;	  (exit 1)))
+;    
+;    (sretrieve:db-do
+;     configdat
+;     (lambda (db)
+;       (sretrieve:register-action db "get" retriever datadir comment)))
+;      (sretrieve:do-as-calling-user
+;       (lambda ()
+;         (if (directory? datadir)
+;	   (begin
+;  	    (change-directory datadir)
+;	    (let ((files (filter (lambda (x)
+;				(not (member x '("." ".."))))
+;			      (glob "*" ".*"))))
+;	     (print "files: " files)
+;	     (process-execute "/bin/tar" (append (append (list  "chfv" "-") files) (list "--ignore-failed-read")))))
+;             (begin
+;               (let* ((parent-dir (pathname-directory datadir) )
+;                      (filename  (conc(pathname-file datadir) "." (pathname-extension datadir))))
+;                  (change-directory parent-dir)  
+;                  (process-execute "/bin/tar" (list "chfv" "-" filename))
+;             )))
+;))))
+;
+;
+;;; copy in file to dest, validation is done BEFORE calling this
+;;;
+;(define (sretrieve:cp configdat retriever file comment)
+;  (let* ((base-dir  (configf:lookup configdat "settings" "base-dir"))
+;         (allowed-sub-paths (configf:lookup configdat "settings" "allowed-sub-paths"))    
+;	 (datadir   (conc base-dir "/" file))
+;         (filename  (conc(pathname-file datadir) "." (pathname-extension datadir))))
+;    (if (or (not base-dir)
+;	    (not (file-exists? base-dir)))
+;	(begin
+;	  (debug:print 0 "ERROR: Bad configuration! base-dir " base-dir " not found")
+;	  (exit 1)))
+;    (print datadir)
+;    (if (not (file-exists? datadir))
+;	(begin
+;	  (debug:print 0 "ERROR: File  (" file "), not found at " base-dir "." )
+;	  (exit 1)))
+;    (if (directory? datadir)
+;	(begin
+;	  (debug:print 0 "ERROR: (" file ") is a dirctory!! cp cmd works only on files ." )
+;	  (exit 1)))
+;    (if(not (string-match (regexp  allowed-sub-paths) file))
+;        (begin
+;	  (debug:print 0 "ERROR: Access denied to file (" file ")!! " )
+;	  (exit 1)))
+;     
+;     (sretrieve:db-do
+;     configdat
+;     (lambda (db)
+;       (sretrieve:register-action db "cp" retriever datadir comment)))
+;      (sretrieve:do-as-calling-user
+;      ;;  (debug:print 0 "ph:  "(pathname-directory datadir)  "!! " )
+;       (change-directory (pathname-directory datadir))  
+;       ;;(debug:print 0 "ph: /bin/tar" (list "chfv" "-" filename) )
+;      (process-execute "/bin/tar" (list "chfv" "-" filename)))
+;      ))
+;
+;;; ls in file to dest, validation is done BEFORE calling this
+;;;
+;(define (sretrieve:ls configdat retriever file comment)
+;  (let* ((base-dir  (configf:lookup configdat "settings" "base-dir"))
+;         (allowed-sub-paths (configf:lookup configdat "settings" "allowed-sub-paths"))    
+;	 (datadir   (conc base-dir "/" file))
+;         (filename  (conc(pathname-file datadir) "." (pathname-extension datadir))))
+;    (if (or (not base-dir)
+;	    (not (file-exists? base-dir)))
+;	(begin
+;	  (debug:print 0 "ERROR: Bad configuration! base-dir " base-dir " not found")
+;	  (exit 1)))
+;    (print datadir)
+;    (if (not (file-exists? datadir))
+;	(begin
+;	  (debug:print 0 "ERROR: File  (" file "), not found at " base-dir "." )
+;	  (exit 1)))
+;      (if(not (string-match (regexp  allowed-sub-paths) file))
+;        (begin
+;	  (debug:print 0 "ERROR: Access denied to file (" file ")!! " )
+;	  (exit 1)))
+;   
+;        (sretrieve:do-as-calling-user
+;        (lambda ()
+;	  (process-execute "/bin/ls" (list "-ls"  "-lrt" datadir ))
+; ))))
+
+
 
 (define (sretrieve:validate target-dir targ-mk)
   (let* ((normal-path (normalize-pathname targ-mk))
         (targ-path (conc target-dir "/" normal-path)))
     (if (string-contains   normal-path "..")
     (begin
-      (debug:print-error 0 *default-log-port* "Path  " targ-mk " resolved outside target area "  target-dir )
+      (debug:print 0 "ERROR: Path  " targ-mk " resolved outside target area "  target-dir )
       (exit 1)))
 
     (if (not (string-contains targ-path target-dir))
     (begin
-      (debug:print-error 0 *default-log-port* "You cannot update data outside " target-dir ".")
+      (debug:print 0 "ERROR: You cannot update data outside " target-dir ".")
       (exit 1)))
-    (debug:print 0 *default-log-port* "Path " targ-mk " is valid.")   
+    (debug:print 0 "Path " targ-mk " is valid.")   
  ))
-;; make directory in dest
-;;
-
-(define (sretrieve:mkdir configdat submitter target-dir targ-mk comment)
-  (let ((targ-path (conc target-dir "/" targ-mk)))
-    
-    (if (file-exists? targ-path)
-	(begin
-	  (debug:print-error 0 *default-log-port* "target Directory " targ-path " already exist!!")
-	  (exit 1)))
-    (sretrieve:db-do
-     configdat
-     (lambda (db)
-       (sretrieve:register-action db "mkdir" submitter targ-mk comment)))
-    (let* ((th1         (make-thread
-			 (lambda ()
-			   (create-directory targ-path #t)
-			   (debug:print 0 *default-log-port* " ... dir " targ-path " created"))
-			 "mkdir thread"))
-	   (th2         (make-thread
-			 (lambda ()
-			   (let loop ()
-			     (thread-sleep! 15)
-			     (display ".")
-			     (flush-output)
-			     (loop)))
-			 "action is happening thread")))
-      (thread-start! th1)
-      (thread-start! th2)
-      (thread-join! th1))
-    (cons #t "Successfully saved data")))
-
-;; create a symlink in dest
-;;
-(define (sretrieve:ln configdat submitter target-dir targ-link link-name comment)
-  (let ((targ-path (conc target-dir "/" link-name)))
-    (if (file-exists? targ-path)
-	(begin
-	  (debug:print-error 0 *default-log-port* "target file " targ-path " already exist!!")
-	  (exit 1)))
-     (if (not (file-exists? targ-link ))
-	(begin
-	  (debug:print-error 0 *default-log-port* "target file " targ-link " does not exist!!")
-	  (exit 1)))
- 
-    (sretrieve:db-do
-     configdat
-     (lambda (db)
-       (sretrieve:register-action db "ln" submitter link-name comment)))
-    (let* ((th1         (make-thread
-			 (lambda ()
-			   (create-symbolic-link targ-link targ-path  )
-			   (debug:print 0 *default-log-port* " ... link " targ-path " created"))
-			 "symlink thread"))
-	   (th2         (make-thread
-			 (lambda ()
-			   (let loop ()
-			     (thread-sleep! 15)
-			     (display ".")
-			     (flush-output)
-			     (loop)))
-			 "action is happening thread")))
-      (thread-start! th1)
-      (thread-start! th2)
-      (thread-join! th1))
-    (cons #t "Successfully saved data")))
-
-
-;; remove copy of file in dest
-;;
-(define (sretrieve:rm configdat submitter target-dir targ-file comment)
-  (let ((targ-path (conc target-dir "/" targ-file)))
-    (if (not (file-exists? targ-path))
-	(begin
-	  (debug:print-error 0 *default-log-port* "target file " targ-path " not found, nothing to remove.")
-	  (exit 1)))
-    (sretrieve:db-do
-     configdat
-     (lambda (db)
-       (sretrieve:register-action db "rm" submitter targ-file comment)))
-    (let* ((th1         (make-thread
-			 (lambda ()
-			   (delete-file targ-path)
-			   (debug:print 0 *default-log-port* " ... file " targ-path " removed"))
-			 "rm thread"))
-	   (th2         (make-thread
-			 (lambda ()
-			   (let loop ()
-			     (thread-sleep! 15)
-			     (display ".")
-			     (flush-output)
-			     (loop)))
-			 "action is happening thread")))
-      (thread-start! th1)
-      (thread-start! th2)
-      (thread-join! th1))
-    (cons #t "Successfully saved data")))
-
-(define (sretrieve:backup-move path)
-  (let* ((trashdir  (conc (pathname-directory path) "/.trash"))
-	 (trashfile (conc trashdir "/" (current-seconds) "-" (pathname-file path))))
-    (create-directory trashdir #t)
-    (if (directory? path)
-	(system (conc "mv " path " " trashfile))
-	(file-move path trash-file))))
-
-
-(define (sretrieve:lst->path pathlst)
-  (conc "/" (string-intersperse (map conc pathlst) "/")))
-
-(define (sretrieve:path->lst path)
-  (string-split path "/"))
-
-(define (sretrieve:pathdat-apply-heuristics configdat path)
-  (cond
-   ((file-exists? path) "found")
-   (else (conc path " not installed"))))
+
+
+;(define (sretrieve:backup-move path)
+;  (let* ((trashdir  (conc (pathname-directory path) "/.trash"))
+;	 (trashfile (conc trashdir "/" (current-seconds) "-" (pathname-file path))))
+;    (create-directory trashdir #t)
+;    (if (directory? path)
+;	(system (conc "mv " path " " trashfile))
+;	(file-move path trash-file))))
+;
+;
+;(define (sretrieve:lst->path pathlst)
+;  (conc "/" (string-intersperse (map conc pathlst) "/")))
+;
+;(define (sretrieve:path->lst path)
+;  (string-split path "/"))
+;
+;(define (sretrieve:pathdat-apply-heuristics configdat path)
+;  (cond
+;   ((file-exists? path) "found")
+;   (else (conc path " not installed"))))
 
 ;;======================================================================
 ;; MISC
 ;;======================================================================
 
@@ -392,11 +279,11 @@
 (define (sretrieve:do-as-calling-user proc)
   (let ((eid (current-effective-user-id))
         (cid (current-user-id)))
     (if (not (eq? eid cid)) ;; running suid
             (set! (current-effective-user-id) cid))
-    ;; (debug:print 0 *default-log-port* "running as " (current-effective-user-id))
+    ;; (debug:print 0 "running as " (current-effective-user-id))
     (proc)
     (if (not (eq? eid cid))
         (set! (current-effective-user-id) eid))))
 
 (define (sretrieve:find name paths)
@@ -417,203 +304,770 @@
 
 ;;======================================================================
 ;; SHELL
 ;;======================================================================
 
-(define (toplevel-command . args) #f)
-(define (sretrieve:shell)
+;; Create the sqlite db for shell
+;(define (sretrieve:shell-db-do path proc) 
+;    (if (not path)
+;	(begin
+;	  (debug:print 0 "[database]\nlocation /some/path\n\n Is missing from the config file!")
+;	  (exit 1)))
+;    (if (and path
+;	     (directory? path)
+;	     (file-read-access? path))
+;	(let* ((dbpath    (conc path "/" *exe-name* ".db"))
+;	       (writeable (file-write-access? dbpath))
+;	       (dbexists  (file-exists? dbpath)))
+;	  (handle-exceptions
+;	   exn
+;	   (begin
+;	     (debug:print 2 "ERROR: problem accessing db " dbpath
+;			  ((condition-property-accessor 'exn 'message) exn))
+;	     (exit 1))
+;            ;;(debug:print 0 "calling proc " proc "db path " dbpath )
+;	   (call-with-database
+;            dbpath
+;	    (lambda (db)
+;	       ;;(debug:print 0 "calling proc " proc " on db " db)
+;	      (set-busy-handler! db (busy-timeout 10000)) ;; 10 sec timeout
+;	      (if (not dbexists)(sretrieve:initialize-db db))
+;	      (proc db)))))
+;	(debug:print 0 "ERROR: invalid path for storing database: " path)))
+
+
+
+;; function to find sheets to which use has access 
+(define (sretrieve:has-permission  area)
+  (let ((username     (current-user-name)))
+  (cond
+   ((is-admin username)
+     #t)
+   ((is-user "retrieve" username area) 
+     #t)
+    ((is-user "publish" username area) 
+     #t)
+   ((is-user "writer-admin" username area) 
+     #t)
+   ((is-user "read-admin" username area) 
+     #t)
+   ((is-user "area-admin" username area) 
+     #t)
+   (else  
+    #f))))
+ 
+
+(define (sretrieve:get-accessable-projects  area)
+   (let* ((projects `()))
+         
+        (if (sretrieve:has-permission area)
+               (set! projects (cons area projects))
+               (begin
+                 (print "User cannot access area " area "!!")  
+                (exit 1))) 
+   ; (print projects)
+    projects))
+		 
+(define (sauth-common:shell-ls-cmd base-path-list ext-path top-areas base-path tail-cmd-list)
+    (if (and (null? base-path-list) (equal? ext-path "") )
+      (print (string-intersperse top-areas " "))
+  (let* ((resolved-path (sauth-common:resolve-path ext-path base-path-list top-areas )))
+           ;(print resolved-path)
+           (if (not (equal? resolved-path #f))
+           (if (null? resolved-path) 
+             (print (string-intersperse top-areas " "))
+           (let* ((target-path (sauth-common:get-target-path  base-path-list  ext-path top-areas base-path)))
+                ;(print "Resolved path: " target-path)
+                (if (not (equal? target-path #f))
+                  (begin   
+                (if (symbolic-link? target-path)
+                   (set! target-path (conc target-path "/"))) 
+                (if (not (equal? target-path #f))
+                (begin 
+                (cond
+		  ((null? tail-cmd-list)
+		     (run (pipe
+      	      	      (ls "-lrt" ,target-path))))
+		  ((not (equal? (car tail-cmd-list) "|"))
+                         (print "ls cmd cannot accept "(string-join tail-cmd-list) " as an argument!!"))
+                  (else  
+                    (run (pipe
+      	      	      (ls "-lrt" ,target-path)
+                      (begin (system (string-join (cdr tail-cmd-list))))))
+      ))))))))))))
+
+(define (sretrieve:shell-cat-cmd base-pathlist ext-path top-areas base-path tail-cmd-list)
+  (let* ((resolved-path (sauth-common:resolve-path ext-path base-pathlist top-areas ))
+          (data "") )
+         (if (not (equal? resolved-path #f))
+           (if (null? resolved-path) 
+             (print "Path could not be resolved!!")
+           (let* ((target-path (sauth-common:get-target-path  base-pathlist  ext-path top-areas base-path)))
+             (if (not (equal? target-path #f))
+               (if (or (not (file-exists? target-path)) (directory? target-path))
+               (print "Target path does not exist or is a directory!") 
+               (begin 
+                 (cond
+		  ((null? tail-cmd-list)
+		     (run (pipe
+      	      	      (cat  ,target-path))))
+		  ((not (equal? (car tail-cmd-list) "|"))
+                         (print "cat cmd cannot accept "(string-join tail-cmd-list) " as an argument!!"))
+                  (else  
+                    (run (pipe
+      	      	      (cat ,target-path)
+                      (begin (system (string-join (cdr tail-cmd-list))))))))))
+)))
+             (print "Path could not be resolved!!"))))
+
+(define (get-options cmd-list split-str)
+    (if (null? cmd-list)
+              (list '() '())
+    (let loop ((hed (car cmd-list))
+		 (tal (cdr cmd-list))
+                  (res '()))
+                   (cond
+                   ((equal? hed split-str)
+                      (list res tal))
+                   ((null? tal)
+                      (list (cons hed res) tal)) 
+                   (else 
+		  	(loop (car tal)(cdr tal)(cons hed res)))))))
+
+  
+(define (sretrieve:shell-grep-cmd base-pathlist ext-path top-areas base-path tail-cmd-list)
+  (let* ((resolved-path (sauth-common:resolve-path ext-path base-pathlist top-areas ))
+          (pattern (car tail-cmd-list))
+          (pipe-cmd-list (get-options (cdr tail-cmd-list) "|"))
+          (options (string-join (car pipe-cmd-list)))
+          (pipe-cmd (cadr  pipe-cmd-list))
+          (redirect-split (string-split (string-join  tail-cmd-list) ">"))   )
+         (if(and ( > (length redirect-split) 2 ))
+            (print "sgrep  cmd cannot accept > " (string-join redirect-split) " as an argument!!" )  
+         (if (not (equal? resolved-path #f))
+           (if (null? resolved-path) 
+             (print "Path could not be resolved!!")
+           (let* ((target-path (sauth-common:get-target-path  base-pathlist  ext-path top-areas base-path))
+                  (restrictions (if (equal? target-path #f)
+                                                 ""
+                                               (sretrieve:shell-lookup base-path)))
+                 (rest-str  (string-split (conc " --exclude-dir=" (string-join (string-split restrictions ",") " --exclude-dir=") ))))
+             (if (not (file-exists? target-path))
+               (print "Target path does not exist!") 
+               (begin 
+                 (cond
+	 	  ((and (null? pipe-cmd) (string-null? options))
+	 	     (run (pipe
+      	      	      (grep ,pattern ,target-path ))))
+		  ((and (null? pipe-cmd) (not (string-null? options)))
+		     (run (pipe
+      	      	      (begin (process-execute "/usr/bin/grep" (append (list options pattern target-path) rest-str))))))
+                  ((and (not (null? pipe-cmd)) (string-null? options))
+                        (run (pipe
+      	      	      (grep ,exclude-dir ,pattern ,target-path)
+                      (begin (system (string-join pipe-cmd))))))
+                  (else   
+                      (run (pipe
+      	      	      ;(grep  ,options ,exclude-dir ,pattern ,target-path)
+                       (begin (process-execute "/usr/bin/grep" (append (list options pattern target-path) rest-str)))
+
+                      (begin (system (string-join  pipe-cmd)))))))
+))))
+             (print "Path could not be resolved!!")))))
+
+
+(define (sretrieve:shell-less-cmd base-pathlist ext-path top-areas base-path)
+  (let* ((resolved-path (sauth-common:resolve-path ext-path base-pathlist top-areas )))
+         (if (not (equal? resolved-path #f))
+           (if (null? resolved-path) 
+             (print "Path could not be resolved!!")
+           (let* ((target-path (sauth-common:get-target-path  base-pathlist  ext-path top-areas base-path)))
+               (if (not (equal? target-path #f))
+           	 (if (or (not (file-exists? target-path)) (directory? target-path))
+                   (print "Target path does not exist or is a directory!") 
+                   (begin 
+                     ;(sretrieve:shell-db-do
+         	     ;     db-location
+     		     ;	  (lambda (db)
+       		;		(sretrieve:register-action db "less" (current-user-name) target-path (conc "Executing cmd: less "  target-path))))   
+ 
+                     (setenv "LESSSECURE" "1")
+                     (run (pipe
+      	      	     (less ,target-path))))))))
+             (print "Path could not be resolved!!"))))
+
+
+
+(define (sretrieve:shell-lookup base-path)
+  (let* ((usr (current-user-name))
+          (value (get-restrictions base-path usr)))
+                              value))
+             
+
+(define (sretrieve:load-shell-config fname)
+          (if (file-exists? fname)
+	(read-config fname #f #f)
+	))
+
+
+(define (is_directory target-path) 
+  (let* ((retval #f))
+  (sretrieve:do-as-calling-user
+    	(lambda ()
+          ;(print (current-effective-user-id) ) 
+          (if (directory? target-path)
+               (set! retval  #t))))
+             ;(print (current-effective-user-id))
+     retval)) 
+
+(define (make-exclude-pattern  restriction-list  )
+  (if (null? restriction-list)
+     ""
+   (let loop ((hed (car restriction-list))
+		 (tal (cdr restriction-list))
+                  (ret-str ""))
+                   (cond
+                   ((null? tal)
+                      (conc ret-str ".+" hed ".*")) 
+                   (else 
+		  	(loop (car tal)(cdr tal)(conc ret-str ".+" hed ".*|"))))))    )
+
+(define (sretrieve:get-shell-cmd target-path base-path restrictions iport)
+     (if (not (file-exists? target-path))
+        (sauth:print-error "Target path does not exist!")
+    (begin
+    (if (not (equal? target-path #f))
+    (begin     
+        (if (is_directory target-path) 
+        (begin
+           (let* ((tmpfile (conc "/tmp/" (current-user-name) "/my-pipe"))
+                  (parent-dir target-path)
+                  (last-dir-name (if  (pathname-extension target-path)  
+                                      (conc(pathname-file target-path) "." (pathname-extension target-path))
+                                      (pathname-file target-path)))
+                  (curr-dir (current-directory))   
+                  (start-dir (conc (current-directory) "/" last-dir-name))
+                  (execlude (make-exclude-pattern (string-split restrictions ","))))
+                  ; (print tmpfile)
+                    (if  (file-exists? start-dir)
+                    (begin
+                         (print last-dir-name " already exist in your work dir. Do you want to over write it? [y|n]")
+                        (let* ((inl (read-line iport)))
+                            (if (equal? inl "y")
+                              (begin
+                                 (change-directory parent-dir)
+                                  (create-fifo  tmpfile)
+                                  (process-fork 
+    				   (lambda()
+                                       (sleep 1) 
+       					(with-output-to-file tmpfile
+         				(lambda ()
+            				(sretrieve:make_file parent-dir execlude parent-dir)))))
+ 
+                                  (run (pipe
+                   		   (tar "chfv" "-" "-T" ,tmpfile )
+                   		   (begin (system (conc "cd " start-dir ";tar  xUf - "   )))))
+                                   (change-directory curr-dir)
+                                    (system (conc "rm " tmpfile)) )
+			      (begin	
+                               (print  "Nothing has been retrieved!!  ")))))
+                     (begin
+                       (sretrieve:do-as-calling-user
+                    (lambda ()
+		      (create-directory start-dir #t)))
+                          (change-directory parent-dir)
+                          ; (print execlude)
+                           (create-fifo tmpfile)
+                            (process-fork 
+    				   (lambda()
+                                       (sleep 1) 
+       					(with-output-to-file tmpfile
+         				(lambda ()
+            				(sretrieve:make_file parent-dir execlude parent-dir)))))
+
+                                  (run (pipe
+                   		   (tar "chfv" "-"  "-T" ,tmpfile)
+                   		   (begin (system (conc "cd " start-dir ";tar  xUf - "    )))))
+                           (change-directory curr-dir)
+                            (system (conc "rm " tmpfile)))))) 
+        (begin
+           (let*((parent-dir (pathname-directory target-path))
+                 (start-dir (current-directory))
+                 (filename (if  (pathname-extension target-path)  
+                                      (conc(pathname-file target-path) "." (pathname-extension target-path))
+                                      (pathname-file target-path)))
+                 (work-dir-file (conc (current-directory) "/" filename)))
+                 (if  (file-exists? work-dir-file)
+                    (begin
+                       (print filename " already exist in your work dir. Do you want to over write it? [y|n]")
+                        (let* ((inl (read-line iport)))
+                            (if (equal? inl "y")
+                              (begin
+                                 (change-directory parent-dir)
+                                  (run (pipe
+                   		   (tar "chfv" "-" ,filename)
+                   		   (begin (system (conc "cd " start-dir ";tar  xUf - "   )))))
+                                     (change-directory start-dir))
+			      (begin	
+                               (print  "Nothing has been retrieved!!  ")))))
+                    (begin
+               (change-directory parent-dir)  
+                 (run (pipe
+                   (tar "chfv" "-" ,filename)
+                   (begin (system (conc "cd " start-dir ";tar xUf -")))))
+                    (change-directory start-dir)))))))))))
+
+(define (sretrieve:get-shell-cmd-line target-path base-path restrictions iport)
+   (handle-exceptions
+	   exn 
+	   (begin
+	     (sauth:print-error (conc "Problem fetching the data. Sauth provieds sudo access to only one unix group. Please ensure you have washed all the remaining groups. System Error: " 
+			  ((condition-property-accessor 'exn 'message) exn)))
+	     (exit 1))
+  
+    (if (not (file-exists? target-path))
+        (sauth:print-error "Error:Target path does not exist!")
+    (begin
+    (if (not (equal? target-path #f))
+    (begin     
+        (if (is_directory target-path) 
+        (begin
+           (let* ((parent-dir target-path)
+                  (last-dir-name (if  (pathname-extension target-path)  
+                                      (conc(pathname-file target-path) "." (pathname-extension target-path))
+                                      (pathname-file target-path)))
+                  (curr-dir (current-directory))   
+                  (start-dir (conc (current-directory) "/" last-dir-name))
+                  (execlude (make-exclude-pattern (string-split restrictions ",")))
+                   (tmpfile (conc "/tmp/" (current-user-name) "/my-pipe-" (current-process-id))))
+                    (if  (file-exists? start-dir)
+                    (begin
+                         (sauth:print-error (conclast-dir-name " already exist in your work dir."))
+                         (sauth:print-error  "Nothing has been retrieved!!  "))
+                     (begin
+                   ;    (sretrieve:do-as-calling-user
+                   ; (lambda ()
+                    
+                  (if (not (file-exists?  (conc "/tmp/" (current-user-name)))) 
+		      (create-directory (conc "/tmp/" (current-user-name)) #t))
+                          (change-directory parent-dir)
+                            (create-fifo  tmpfile)
+                                  (process-fork 
+    				   (lambda()
+                                       (sleep 1) 
+       					(with-output-to-file tmpfile
+         				(lambda ()
+            				(sretrieve:make_file parent-dir execlude parent-dir)))))
+
+                           (process-execute "/bin/tar" (append (list  "chfv" "-"  "-T" tmpfile)  (list "--ignore-failed-read")))    
+                                  ;(run (pipe
+                   		   ;(tar "chfv" "-" "." )
+                   		   ;(begin (system (conc "cd " start-dir ";tar  xUf - "   execlude )))))
+                            (system (conc "rm " tmpfile))    
+                           (change-directory curr-dir))))) 
+        (begin
+           (let*((parent-dir (pathname-directory target-path))
+                 (start-dir (current-directory))
+                 (filename (if  (pathname-extension target-path)  
+                                      (conc(pathname-file target-path) "." (pathname-extension target-path))
+                                      (pathname-file target-path)))
+                 (work-dir-file (conc (current-directory) "/" filename)))
+                 (if  (file-exists? work-dir-file)
+                    (begin
+                       (print filename " already exist in your work dir.")
+                               (print  "Nothing has been retrieved!!  "))
+                    (begin
+               (change-directory parent-dir)
+                (process-execute "/bin/tar" (append (append (list  "chfv" "-") (list filename)) (list "--ignore-failed-read"))) 
+                 ;(run (pipe
+                  ; (tar "chfv" "-" ,filename)
+                  ; (begin (system (conc "cd " start-dir ";tar xUf -")))))
+                    (change-directory start-dir))))))))))))
+
+(define (sretrieve:make_file path exclude base_path)
+   (find-files 
+     path
+     action: (lambda (p res)
+           (cond
+                ((symbolic-link? p)   
+                 (if (directory?(read-symbolic-link p)) 
+                      (sretrieve:make_file p exclude base_path)
+                      (print (string-substitute (conc base_path "/") "" p "-"))))
+                 ((directory? p)              
+                 ;;do nothing for dirs)
+                 ) 
+                (else 
+                                        
+                     (if (not (string-match (regexp exclude)  p ))
+                        (print (string-substitute (conc base_path "/") "" p "-"))))))))
+
+(define (sretrieve:shell-help)
+(conc "Usage: " *exe-name* " [action [params ...]]
+
+  ls    [target path]               	  : list contents of target area. The output of the cmd can be piped into other system cmd. eg ls  | grep txt
+  cd    	     	  : To change the current directory within the sretrive shell. 
+  pwd				     	  : Prints the full pathname of the current directory within the sretrive shell.
+  get        	  : download directory/files into the directory where sretrieve shell cmd was invoked   
+  less  		     	  : Read input file to allows backward movement in the file as well as forward movement 
+  cat                     	  : show the contents of a file. The output of the cmd can be piped into other system cmd.
+
+  sgrep   [options] : Similar to unix grep cmd But with diffrent parameter ordering. The output of the cmd can be piped into other system cmd. 
+Part of the Megatest tool suite.
+Learn more at http://www.kiatoa.com/fossils/megatest
+
+Version: " megatest-fossil-hash)
+)	
+;(define (toplevel-command . args) #f)
+(define (sretrieve:shell area)
+ ; (print area)
   (use readline)
   (let* ((path      '())
-	 (prompt    "> ")
-	 (top-areas '("mrwellan" "pjhatwal" "bjbarcla" "ritikaag" "jmoon18"))
+	 (prompt    "sretrieve> ")
+	 (args      (argv))
+         (usr (current-user-name) )   
+         (top-areas (sretrieve:get-accessable-projects area))
+         (close-port     #f)
+         (area-obj  (get-obj-by-code area))
+         (user-obj (get-user usr)) 
+         (base-path (if (null? area-obj) 
+                         "" 
+                        (caddr (cdr area-obj))))      
 	 (iport     (make-readline-port prompt)))
-    (install-history-file) ;;  [homedir] [filename] [nlines])
-    (with-input-from-port iport
-      (lambda ()
-	(let loop ((inl (read-line)))
-	  (if (not (or (eof-object? inl)
-		       (equal? inl "exit")))
+        (if (null? area-obj)
+          (begin 
+             (print "Area " area " does not exist")
+          (exit 1)))
+	(let loop ((inl (read-line iport)))
+          ;(print 1) 
+	  (if (not (or (or (eof-object? inl)
+		       (equal? inl "exit")) (port-closed? iport)))
 	      (let* ((parts (string-split inl))
 		     (cmd   (if (null? parts) #f (car parts))))
-		(if (not cmd)
+              ;  (print "2")
+		(if (and (not cmd) (not (port-closed? iport)))
 		    (loop (read-line))
 		    (case (string->symbol cmd)
 		      ((cd)
 		       (if (> (length parts) 1) ;; have a parameter
-			   (set! path (append path (string-split (cadr parts)))) ;; not correct for relative paths
-			   (set! path '())))
+                           (begin
+                             (let*((arg (cadr parts))
+                                   (resolved-path (sauth-common:resolve-path  arg path top-areas))
+                                   (target-path (sauth-common:get-target-path path  arg top-areas base-path)))
+                                 (if (not (equal? target-path #f))
+                                 (if (or (equal? resolved-path #f) (not (file-exists? target-path)))    
+                                 (print "Invalid argument " arg ".. ")
+                                  (begin      
+			            (set! path resolved-path)
+                                     (sauthorize:do-as-calling-user
+                              (lambda ()
+			    (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "\"" inl "\"") (number->string (car user-obj))  (number->string (caddr area-obj))  "cd"))))
+                                  )))))  
+   			   (set! path '())))
+                      ((pwd)
+                         (if (null? path)
+                           (print "/")  
+                           (print "/" (string-join path "/")))) 
 		      ((ls)
 		       (let* ((thepath (if (> (length parts) 1) ;; have a parameter
 					   (cdr parts)
-					   path))
+					   `()))
+			      (plen    (length thepath)))
+                         (cond
+			  ((null? thepath)
+                           (sauth-common:shell-ls-cmd path "" top-areas base-path  '())
+                            (sauthorize:do-as-calling-user
+                              (lambda ()
+			    (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "\"" inl "\"") (number->string (car user-obj))  (number->string (caddr area-obj))  "ls"))))   )
+			  ((< plen 2)
+                  
+                            (sauth-common:shell-ls-cmd path  (car thepath) top-areas base-path '())
+                              (sauthorize:do-as-calling-user
+                              (lambda ()
+			    (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "\"" inl "\"") (number->string (car user-obj))  (number->string (caddr area-obj))  "ls")))))
+                          (else 
+                            (if (equal? (car thepath) "|")
+                              (sauth-common:shell-ls-cmd path "" top-areas base-path thepath)
+                              (sauth-common:shell-ls-cmd path  (car thepath) top-areas base-path (cdr thepath)))
+                           (sauthorize:do-as-calling-user
+                              (lambda ()
+			    (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "\"" inl "\"") (number->string (car user-obj))  (number->string (caddr area-obj))  "ls"))))))))
+                       ((cat)
+		       (let* ((thepath (if (> (length parts) 1) ;; have a parameter
+					   (cdr parts)
+					   `()))
+			      (plen    (length thepath)))
+			 (cond
+			  ((null? thepath)
+                          (print "Error: Missing argument to cat"))
+			  ((< plen 2)
+                            (sretrieve:shell-cat-cmd path  (car thepath) top-areas base-path '())
+                              (sauthorize:do-as-calling-user
+                              (lambda ()
+			    (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "\"" inl "\"") (number->string (car user-obj))  (number->string (caddr area-obj))  "cat")))))
+
+			  (else
+                             (sretrieve:shell-cat-cmd path  (car thepath) top-areas base-path (cdr thepath))
+                             (sauthorize:do-as-calling-user
+                              (lambda ()
+			    (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "\"" inl "\"") (number->string (car user-obj))  (number->string (caddr area-obj))  "cat"))))
+))))
+                       ((sgrep)
+		       (let* ((thepath (if (> (length parts) 1) ;; have a parameter
+					   (cdr parts)
+					   `()))
+			      (plen    (length thepath)))
+			 (cond
+			  ((null? thepath) 
+                            (print "Error: Missing arguments to grep!! Useage: grep   [options] "))
+                          ((< plen  2)
+                          (print "Error: Missing arguments to grep!! Useage: grep   [options] "))
+			  (else
+                             (sretrieve:shell-grep-cmd path  (car thepath) top-areas base-path  (cdr thepath))
+				(sauthorize:do-as-calling-user
+                              (lambda ()
+			    (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "\"" inl "\"") (number->string (car user-obj))  (number->string (caddr area-obj))  "grep"))))))))
+
+                      ((less)
+		       (let* ((thepath (if (> (length parts) 1) ;; have a parameter
+					   (cdr parts)
+					   `()))
+			      (plen    (length thepath)))
+			 (cond
+			  ((null? thepath)
+                          (print "Error: Missing argument to less"))
+			  ((< plen 2)
+                            (sretrieve:shell-less-cmd path  (car thepath) top-areas base-path)
+                             (sauthorize:do-as-calling-user
+                              (lambda ()
+			    (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "\"" inl "\"") (number->string (car user-obj))  (number->string (caddr area-obj))  "less")))))
+			  (else
+                             (print "less cmd takes only one () argument!!")))))
+                      ((get)
+                         (let* ((thepath (if (> (length parts) 1) ;; have a parameter
+					   (cdr parts)
+					   `()))
 			      (plen    (length thepath)))
 			 (cond
 			  ((null? thepath)
-			   (print (string-intersperse top-areas " ")))
-			  ((and (< plen 2)
-				(member (car thepath) top-areas))
-			   (system (conc "ls /p/fdk/gwa/" (car thepath))))
-			  (else ;; have a long path
-			   ;; check for access rights here
-			   (system (conc "ls /p/fdk/gwa/" (string-intersperse thepath "/")))))))
+                          (print "Error: Missing argument  to get"))
+			  ((< plen 2)
+                           (let* ((target-path (sauth-common:get-target-path path  (car thepath) top-areas base-path))
+				 (restrictions (if (equal? target-path #f)
+                                                 ""
+                                               (sretrieve:shell-lookup base-path))))
+                               (if (not (equal? target-path #f))
+                             (begin  
+                                 (sretrieve:get-shell-cmd target-path base-path restrictions iport)
+                                  (sauthorize:do-as-calling-user
+                              (lambda ()
+			    (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "\"" inl "\"") (number->string (car user-obj))  (number->string (caddr area-obj))  "get"))))))))
+			  (else
+                            (print "Error: get cmd takes only one argument ")))))
+                      ((exit)
+                          (print "got exit"))  
+                      ((help)
+                          (print (sretrieve:shell-help)))
 		      (else 
 		       (print "Got command: " inl))))
-		(loop (read-line)))))))))
+                 (loop (read-line iport)))))))
+;;))
     
 
 ;;======================================================================
 ;; MAIN
 ;;======================================================================
-
-(define (sretrieve: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)
-	;; (ini:read-ini fname)
-	(read-config fname #f #t)
-	(make-hash-table))))
+;;(define *default-log-port* (current-error-port))
+
+;(define (sretrieve: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)
+;	;; (ini:read-ini fname)
+;	(read-config fname #f #f)
+;	(make-hash-table))))
 
 ;; package-type is "megatest", "builds", "kits" etc.
 ;;
-(define (sretrieve:load-packages configdat exe-dir package-type)
-  (push-directory exe-dir)
-  (let* ((packages-metadir  (configf:lookup configdat "settings" "packages-metadir"))
-	 (conversion-script (configf:lookup configdat "settings" "conversion-script"))
-	 (upstream-file     (configf:lookup configdat "settings" "upstream-file"))
-	 (package-config    (conc packages-metadir "/" package-type ".config")))
-    ;; this section here does a timestamp based rebuild of the
-    ;;   /.config file using
-    ;;    as an input
-    (if (file-exists? upstream-file)
-	(if (or (not (file-exists? package-config)) ;; if not created call the updater, otherwise call only if upstream newer
-		(> (file-modification-time upstream-file)(file-modification-time package-config)))
-	    (handle-exceptions
-	     exn
-	     (debug:print-error 0 *default-log-port* "failed to run script " conversion-script " with params " upstream-file " " package-config)
-	     (let ((pid (process-run conversion-script (list upstream-file package-config))))
-	       (process-wait pid)))
-	    (debug:print 0 *default-log-port* "Skipping update of " package-config " from " upstream-file))
-	(debug:print 0 *default-log-port* "Skipping update of " package-config " as " upstream-file " not found"))
-    ;; (ini:property-separator-patt " *  *")
-    ;; (ini:property-separator #\space)
-    (let ((res (if (file-exists? package-config)
-		   (begin
-		     (debug:print 0 *default-log-port* "Reading package config " package-config)
-		     (read-config package-config #f #t))
-		   (make-hash-table))))
-      (pop-directory)
-      res)))
-
-(define (sretrieve:process-action configdat action . args)
-  (let* ((base-dir      (configf:lookup configdat "settings" "base-dir"))
-	 (user          (current-user-name))
-         (allowed-sub-paths (configf:lookup configdat "settings" "allowed-sub-paths")) 
-	 (allowed-users (string-split
-			 (or (configf:lookup configdat "settings" "allowed-users")
-			     "")))
-	 (default-area  (configf:lookup configdat "settings" "default-area"))) ;; otherwise known as the package
-    
-    (if (not base-dir)
-	(begin
-	  (debug:print 0 *default-log-port* "[settings]\nbase-dir /some/path\n\n Is MISSING from the config file!")
-	  (exit)))
-    (if (null? allowed-users)
-	(begin
-	  (debug:print 0 *default-log-port* "[setings]\nallowed-users user1 user2 ...\n\n Is MISSING from the config file!")
-	  (exit)))
-    (if (not (member user allowed-users))
-	(begin
-	  (debug:print 0 *default-log-port* "User \"" (current-user-name) "\" does not have access. Exiting")
-	  (exit 1)))
+
+;(define (sretrieve:load-packages configdat exe-dir package-type)
+;  (push-directory exe-dir)
+;  (let* ((packages-metadir  (configf:lookup configdat "settings" "packages-metadir"))
+;	 (conversion-script (configf:lookup configdat "settings" "conversion-script"))
+;	 (upstream-file     (configf:lookup configdat "settings" "upstream-file"))
+;	 (package-config    (conc packages-metadir "/" package-type ".config")))
+;       (if (file-exists? upstream-file)
+;	(if (or (not (file-exists? package-config)) ;; if not created call the updater, otherwise call only if upstream newer
+;		(> (file-modification-time upstream-file)(file-modification-time package-config)))
+;	    (handle-exceptions
+;	     exn
+;	     (debug:print 0 "ERROR: failed to run script " conversion-script " with params " upstream-file " " package-config)
+;	     (let ((pid (process-run conversion-script (list upstream-file package-config))))
+;	       (process-wait pid)))
+;	    (debug:print 0 "Skipping update of " package-config " from " upstream-file))
+;	(debug:print 0 "Skipping update of " package-config " as " upstream-file " not found"))
+;       (let ((res (if (file-exists? package-config)
+;		   (begin
+;		     (debug:print 0 "Reading package config " package-config)
+;		     (read-config package-config #f #t))
+;		   (make-hash-table))))
+;      (pop-directory)
+;      res)))
+
+(define (toplevel-command . args) #f)
+(define (sretrieve:process-action  action . args)
+    ; (print action)
+ ;  (use readline)
     (case (string->symbol action)
       ((get)
-       (if (< (length args) 1)
-	   (begin 
-	     (debug:print-error 0 *default-log-port* "Missing arguments; " (string-intersperse args ", "))
-	     (exit 1)))
-       (let* ((remargs     (args:get-args args '("-m" "-i" "-package") '() args:arg-hash 0))
-              (version     (car args))
-	      (msg         (or (args:get-arg "-m") ""))
-	      (package-type (or (args:get-arg "-package")
-				default-area))
-	      (exe-dir     (configf:lookup configdat "exe-info" "exe-dir")))
-;;	      (relconfig   (sretrieve:load-packages configdat exe-dir package-type)))
-
-	 (debug:print 0 *default-log-port* "retrieving " version " of " package-type " as tar data on stdout")
-	 (sretrieve:get configdat user version msg)))
-         ((cp)
-            (if (< (length args) 1)
-             (begin 
-	     (debug:print-error 0 *default-log-port* "Missing arguments; " (string-intersperse args ", "))
-	     (exit 1)))
-          (let* ((remargs     (args:get-args args '("-m" "-i" "-package") '() args:arg-hash 0))
-              (file     (car args))
-	      (msg         (or (args:get-arg "-m") "")) )
-
-	 (debug:print 0 *default-log-port* "copinging " file " to current directory " )
-	 (sretrieve:cp configdat user file msg)))
-      ((ls)
-            (if (< (length args) 1)
-             (begin 
-	     (debug:print-error 0 *default-log-port* "Missing arguments; " (string-intersperse args ", "))
-	     (exit 1)))
-          (let* ((remargs     (args:get-args args '("-m" "-i" "-package") '() args:arg-hash 0))
-              (dir     (car args))
-	      (msg         (or (args:get-arg "-m") "")) )
-
-	 (debug:print 0 *default-log-port* "Listing files in " )
-	 (sretrieve:ls configdat user dir msg)))
- 
-      (else (debug:print 0 *default-log-port* "Unrecognised command " action)))))
-  
-;; ease debugging by loading ~/.dashboardrc - REMOVE FROM PRODUCTION!
-;; (let ((debugcontrolf (conc (get-environment-variable "HOME") "/.sretrieverc")))
-;;   (if (file-exists? debugcontrolf)
-;;       (load debugcontrolf)))
+       (if (< (length args) 2)
+	   (begin 
+	     (sauth:print-error  "Missing arguments;  " )
+	     (exit 1)))
+       (let* ((remargs     (args:get-args args '("-m" ) '() args:arg-hash 0))
+              (iport (make-readline-port ">"))
+              (area     (car args))
+              (usr (current-user-name))
+              (area-obj  (get-obj-by-code area))
+              (user-obj (get-user usr))
+              (top-areas (sretrieve:get-accessable-projects area)) 
+              (base-path (if (null? area-obj) 
+                                      "" 
+                                     (caddr (cdr area-obj))))
+	      (sub-path       (if (null? remargs) 
+                                       "" 
+                                       (car remargs))))
+
+          (if (null? area-obj)
+          	    (begin 
+             		(sauth:print-error (conc "Area " area " does not exist"))
+          	         (exit 1)))
+              (let* ((target-path (sauth-common:get-target-path '()  (conc area "/" sub-path) top-areas base-path))
+		     (restrictions (if (equal? target-path #f)
+                                        ""
+                                       (sretrieve:shell-lookup base-path))))
+             (if (not (equal? target-path #f))
+                 (begin  
+                   (sauthorize:do-as-calling-user
+                      (lambda ()
+   		        (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "get " area " " sub-path) (number->string (car user-obj))  (number->string (caddr area-obj))  "get"))))
+                        (sretrieve:get-shell-cmd-line target-path base-path restrictions  iport))))))
+         ((cp)
+             (if (< (length args) 2)
+	   (begin 
+	     (sauth:print-error  "Missing arguments;  " )
+	     (exit 1)))
+       (let* ((remargs     (args:get-args args '("-m" ) '() args:arg-hash 0))
+              (iport (make-readline-port ">"))
+              (area     (car args))
+              (usr (current-user-name))
+              (area-obj  (get-obj-by-code area))
+              (user-obj (get-user usr))
+              (top-areas (sretrieve:get-accessable-projects area)) 
+              (base-path (if (null? area-obj) 
+                                      "" 
+                                     (caddr (cdr area-obj))))
+	      (sub-path       (if (null? remargs) 
+                                       "" 
+                                       (car remargs))))
+         ;  (print args)
+          (if (null? area-obj)
+          	    (begin 
+             		(sauth:print-error (conc "Area " area " does not exist"))
+          	         (exit 1)))
+              (let* ((target-path (sauth-common:get-target-path '()  (conc area "/" sub-path) top-areas base-path))
+				 (restrictions (if (equal? target-path #f)
+                                                 ""
+                                              (sretrieve:shell-lookup base-path))))
+                          ;(print target-path) 
+                          (if (not (equal? target-path #f))
+                             (begin  
+                              (sauthorize:do-as-calling-user
+                              (lambda ()
+			    (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "get " area " " sub-path) (number->string (car user-obj))  (number->string (caddr area-obj))  "get"))))
+                            (sretrieve:get-shell-cmd-line target-path base-path restrictions  iport))))))
+      ((ls)
+          (cond
+            ((< (length args) 1)
+              (begin 
+	      (print  "ERROR: Missing arguments;  ")
+	      (exit 1)))
+              ((equal? (length args) 1)
+                 (let*  ((area     (car args))
+                         (usr (current-user-name))
+                         (area-obj  (get-obj-by-code area))
+                         (user-obj (get-user usr))
+                         (top-areas (sretrieve:get-accessable-projects area)) 
+                         (base-path (if (null? area-obj) 
+                                      "" 
+                                     (caddr (cdr area-obj)))))
+                  (if (null? area-obj)
+          	    (begin 
+             		(print "Area " area " does not exist")
+          	         (exit 1)))
+           	 (sauth-common:shell-ls-cmd '() area top-areas base-path  '())
+                 (sauthorize:do-as-calling-user
+                   (lambda ()
+		    (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" "ls" (number->string (car user-obj)) (number->string (caddr area-obj)) "ls"))))))
+             ((> (length args) 1)
+               (let*  ((remargs     (args:get-args args '("-m" ) '() args:arg-hash 0))
+                        (usr (current-user-name))
+                        (user-obj (get-user usr))
+                         (area     (car args)))
+                         (let* ((area-obj  (get-obj-by-code area))
+                               (top-areas (sretrieve:get-accessable-projects area)) 
+                               (base-path (if (null? area-obj) 
+                                      "" 
+                                     (caddr (cdr area-obj))))
+                                 
+                               (sub-path (if (null? remargs) 
+                                       area 
+                                      (conc area "/" (car remargs)))))
+                             ;(print "sub path "  sub-path)
+                            (if (null? area-obj)
+          	              (begin 
+             		        (print "Area " area " does not exist")
+          	                 (exit 1)))
+                              (sauth-common:shell-ls-cmd `()  sub-path top-areas base-path '())
+                            (sauthorize:do-as-calling-user
+				(lambda ()
+                       	       (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "ls " sub-path) (number->string (car user-obj)) (number->string (caddr area-obj)) "ls")))))))))
+
+       ((shell)
+          (if (< (length args) 1)
+             (begin 
+	     (print  "ERROR: Missing arguments !!" )
+	     (exit 1))
+             (sretrieve:shell (car args)))) 
+      (else (print 0 "Unrecognised command " action))))
 
 (define (main)
   (let* ((args      (argv))
 	 (prog      (car args))
 	 (rema      (cdr args))
 	 (exe-name  (pathname-file (car (argv))))
 	 (exe-dir   (or (pathname-directory prog)
 			(sretrieve:find exe-name (string-split (get-environment-variable "PATH") ":"))))
-	 (configdat (sretrieve:load-config exe-dir exe-name)))
+	 ;(configdat (sretrieve:load-config exe-dir exe-name))
+)
     ;; preserve the exe data in the config file
-    (hash-table-set! configdat "exe-info" (list (list "exe-name" exe-name)
-						(list "exe-dir"  exe-dir)))
+    ;(hash-table-set! configdat "exe-info" (list (list "exe-name" exe-name)
+					;	(list "exe-dir"  exe-dir)))
     (cond
      ;; one-word commands
      ((eq? (length rema) 1)
       (case (string->symbol (car rema))
 	((help -h -help --h --help)
 	 (print sretrieve:help))
-	((list-vars) ;; print out the ini file
-	 (map print (sretrieve:get-areas configdat)))
-	((ls)
-	 (let* ((base-dir (configf:lookup configdat "settings" "base-dir")))
-	   (if base-dir
-	       (begin
-		 (print "Files in " base-dir)
-                 (sretrieve:do-as-calling-user
-                    (lambda ()
-		 (process-execute "/bin/ls" (list "-lrt" base-dir)))))
-	       (print "ERROR: No base dir specified!"))))
-	((log)
-	 (sretrieve:db-do configdat (lambda (db)
-				     (print "Logs : ")
-				     (query (for-each-row
-					     (lambda (row)
-					       (apply print (intersperse row " | "))))
-					    (sql db "SELECT * FROM actions")))))
-	((shell)
-	 (sretrieve:shell))
 	(else
 	 (print "ERROR: Unrecognised command. Try \"sretrieve help\""))))
      ;; multi-word commands
      ((null? rema)(print sretrieve:help))
      ((>= (length rema) 2)
-      (apply sretrieve:process-action configdat (car rema)(cdr rema)))
-     (else (debug:print-error 0 *default-log-port* "Unrecognised command. Try \"sretrieve help\"")))))
+      
+      (apply sretrieve:process-action  (car rema) (cdr rema)))
+     (else (debug:print 0 "ERROR: Unrecognised command. Try \"sretrieve help\"")))))
 
 (main)
+
+
+      

ADDED   subrun.scm
Index: subrun.scm
==================================================================
--- /dev/null
+++ subrun.scm
@@ -0,0 +1,250 @@
+
+;; 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 program is distributed WITHOUT ANY WARRANTY; without even the
+;;  implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
+;;  PURPOSE.
+
+;;  strftime('%m/%d/%Y %H:%M:%S','now','localtime')
+
+(use (prefix sqlite3 sqlite3:) srfi-1 posix regex regex-case srfi-69 (srfi 18) 
+     posix-extras directory-utils pathname-expand typed-records format
+     call-with-environment-variables)
+(declare (unit subrun))
+;;(declare (uses runs))
+(declare (uses db))
+(declare (uses common))
+;;(declare (uses items))
+;;(declare (uses runconfig))
+;;(declare (uses tests))
+;;(declare (uses server))
+(declare (uses mt))
+;;(declare (uses archive))
+;; (declare (uses filedb))
+
+;(include "common_records.scm")
+;;(include "key_records.scm")
+(include "db_records.scm") ;; provides db:test-get-id
+;;(include "run_records.scm")
+;;(include "test_records.scm")
+
+(define (subrun:subrun-test-initialized? test-run-dir)
+  (if (and (common:file-exists? (conc test-run-dir "/subrun-area") )
+           (common:file-exists? (conc test-run-dir "/testconfig.subrun") ))
+      #t
+      #f))
+
+(define (subrun:launch-dashboard test-run-dir)
+  (if (subrun:subrun-test-initialized? test-run-dir)
+      (let* ((subarea (subrun:get-runarea test-run-dir)))
+        (if (and subarea (common:file-exists? subarea))
+            (system (conc "cd " subarea ";env -i PATH=$PATH DISPLAY=$DISPLAY HOME=$HOME USER=$USER dashboard &"))))))
+
+(define (subrun:subrun-removed? test-run-dir)
+  (if (subrun:subrun-test-initialized? test-run-dir)
+      (let ((flagfile (conc test-run-dir "/subrun.removed")))
+        (if (common:file-exists? flagfile)
+            #t
+            #f))
+      #t))
+
+(define (subrun:set-subrun-removed test-run-dir)
+  (let ((flagfile (conc test-run-dir "/subrun.removed")))
+    (if (and (subrun:subrun-test-initialized? test-run-dir) (not (common:file-exists? flagfile)))
+        (with-output-to-file flagfile
+          (lambda () (print (current-seconds)))))))
+
+(define (subrun:unset-subrun-removed test-run-dir)
+  (let ((flagfile (conc test-run-dir "/subrun.removed")))
+    (if (and (subrun:subrun-test-initialized? test-run-dir) (common:file-exists? flagfile))
+        (delete-file flagfile))))
+
+
+(define (subrun:testconfig-defines-subrun? testconfig)
+  (configf:lookup testconfig "subrun" "runwait")) ;; we use runwait as the flag that a subrun is requested
+
+(define (subrun:initialize-toprun-test  testconfig test-run-dir)
+
+  (let ((ra (configf:lookup testconfig "subrun" "run-area"))
+        (logpro (configf:lookup testconfig "subrun" "logpro"))
+        (symlink-target (conc test-run-dir "/subrun-area"))
+        )
+  (when (not ra)      ;; when runarea is not set we default to *toppath*. However 
+              ;; we need to force the setting in the testconfig so it will
+          ;; be preserved in the testconfig.subrun file
+      (configf:set-section-var testconfig "subrun" "runarea" *toppath*))
+    (configf:set-section-var testconfig "logpro" "subrun" logpro) ;; append the logpro rules to the logpro section as stepname subrun
+
+    (if (common:file-exists? symlink-target)
+        (delete-file symlink-target))
+    
+    (create-symbolic-link ra symlink-target)
+
+    (configf:write-alist testconfig "testconfig.subrun")))
+
+(define (subrun:set-state-status test-run-dir state status new-state-status)
+  (if (and (not (subrun:subrun-removed? test-run-dir)) (subrun:subrun-test-initialized? test-run-dir))
+      (let* ((action-switches-str
+              (conc "-set-state-status "new-state-status
+                    (if state (conc " -state "state) "")
+                    (if status (conc " -status "status) "")))
+             (log-prefix
+              (subrun:sanitize-path
+               (conc "set-state-status="new-state-status
+                     (if state (conc ":state="state) "")
+                     (if status (conc "+status="status) ""))))
+             (submt-result 
+              (subrun:exec-sub-megatest test-run-dir action-switches-str log-prefix)))
+        submt-result)))
+
+(define (subrun:remove-subrun test-run-dir keep-records )
+  (if (and (not (subrun:subrun-removed? test-run-dir)) (subrun:subrun-test-initialized? test-run-dir))
+      (let* ((action-switches-str
+              (conc "-remove-runs"
+                    (if keep-records "-keep-records " "")
+                    ))
+             (remove-result
+              (subrun:exec-sub-megatest test-run-dir action-switches-str "remove")))
+        (if remove-result
+            (begin
+              (subrun:set-subrun-removed test-run-dir)
+              #t)
+            #f))
+      #t))
+
+(define (subrun:launch-cmd test-run-dir)
+  (if (subrun:subrun-removed? test-run-dir)
+      (subrun:unset-subrun-removed test-run-dir))      
+
+  (let* ((log-prefix "run")
+         (switches (subrun:selector+log-switches test-run-dir log-prefix))
+         (run-wait #t)
+         (cmd      (conc "megatest -run "switches" "
+                         (if run-wait "-run-wait " ""))))
+    cmd))
+
+
+(define (subrun:sanitize-path inpath)
+  (let* ((insane-pattern (irregex "[^[a-zA-Z0-9_\\-]")))
+    (regex#string-substitute insane-pattern "_" inpath #t)))
+
+(define (subrun:get-runarea test-run-dir)
+  (if (subrun:subrun-test-initialized? test-run-dir)
+      (let* ((info-alist (subrun:selector+log-alist
+                          test-run-dir
+                          "foo"))
+             (run-area   (if (list? info-alist)
+                             (alist-ref "-start-dir" info-alist equal? #f)
+                             #f)))
+        run-area)
+      #f))
+
+(define (subrun:selector+log-alist test-run-dir log-prefix)
+  (let* ((switch-def-alist (common:get-param-mapping flavor: 'config))
+         (subrunfile   (conc test-run-dir "/testconfig.subrun" ))
+         (subrundata   (with-input-from-file subrunfile read))
+         (subrunconfig (configf:alist->config subrundata))
+         (run-area     (configf:lookup subrunconfig "subrun" "run-area"))
+         (defvals      `(("start-dir" . ,(or run-area  ;; default values if not specified in subrun section of tconf
+                                             (get-environment-variable "MT_RUN_AREA_HOME")
+                                             "/no/rundir/found")) 
+                         ("run-name"  . ,(or (get-environment-variable "MT_RUNNAME") "NO-RUNNAME"))
+                         ("target"    . ,(or (get-environment-variable "MT_TARGET")  "NO-TARGET"))))
+         (switch-alist-pre  (filter-map (lambda (item)
+                                          (let* ((config-key (car item))
+                                                 (switch     (cdr item))
+                                                 (defval     (alist-ref config-key defvals equal? #f))
+                                                 (val        (or (configf:lookup subrunconfig "subrun" config-key)
+                                                                 defval)))
+                                            (if val
+                                                (cons switch val)
+                                                #f)))
+                                        switch-def-alist))
+
+         ;; testpatt may be modified if all three of mode-patt, tag-expr, and testpatt are null
+         (mode-patt     (alist-ref "-modepatt" switch-alist-pre equal? #f))
+         (tag-expr      (alist-ref "-tagexpr" switch-alist-pre equal? #f))
+         (testpatt      (alist-ref "-testpatt" switch-alist-pre equal?
+                                   (if (not (or mode-patt tag-expr)) "%" #f))) ;; testpatt is % if not
+                                                                               ;; otherwise specified
+
+         ;; define compact-stem for logfile
+         (target        (alist-ref "-target" switch-alist-pre equal? #f)) ;; want data-structures alist-ref, not alist-lib alist-ref
+         (runname       (alist-ref "-runname" switch-alist-pre equal? #f))
+
+
+         (compact-stem  (subrun:sanitize-path
+                         (conc
+                          target
+                          "-"
+                          runname
+                          "-" (or testpatt mode-patt tag-expr "NO-TESTPATT"))))
+         (logfile       (conc
+                         test-run-dir "/"
+                         (if log-prefix
+                             (conc (subrun:sanitize-path log-prefix) "-")
+                             "")
+                         compact-stem
+                         ".log"))
+         ;; swap out testpatt with modified test-patt and add -log
+         (switch-alist  (cons
+                         (cons "-log" logfile)
+                         (map (lambda (item)
+                                (if (equal? (car item) "-testpatt")
+                                    (cons "-testpatt" testpatt)
+                                    item))
+                                switch-alist-pre))))
+    switch-alist))
+    ;; note - get precmd from subrun section
+    ;;   apply to submegatest commands
+
+(define (subrun:get-log-path test-run-dir log-prefix)
+  (let* ((alist (subrun:selector+log-alist test-run-dir log-prefix))
+         (res   (alist-ref "-log" alist equal? #f)))
+    res))
+
+(define (subrun:selector+log-switches test-run-dir log-prefix)
+  (let* ((switch-alist (subrun:selector+log-alist test-run-dir log-prefix))
+         (res
+          (string-intersperse
+           (apply
+            append
+            (map
+             (lambda (x)
+               (list (car x) (cdr x)))
+             switch-alist))
+           " ")))
+    res))
+
+(define (subrun:exec-sub-megatest test-run-dir action-switches-str log-prefix)
+  (let* ((selector-switches  (subrun:selector+log-switches test-run-dir log-prefix))
+         (cmd (conc "megatest " selector-switches " " action-switches-str ))
+         (pid #f)
+         (proc (lambda ()
+                 (debug:print-info 0 *default-log-port* "Running sub megatest command: "cmd)
+                 ;;(set! pid (process-run "/usr/bin/xterm" (list ))))))
+                 (set! pid (process-run "/bin/bash" (list "-c" cmd))))))
+    (call-with-environment-variables 
+     (list (cons "PATH" (conc (get-environment-variable "PATH") ":.")))
+     (lambda  ()
+       (common:without-vars proc "^MT_.*")))
+    (let processloop ((i 0))
+      (let-values (((pid-val exit-status exit-code)(process-wait pid #t)))
+        (if (eq? pid-val 0)
+            (begin
+              (thread-sleep! 2)
+              (processloop (+ i 1)))
+            (begin
+              (debug:print-info 0 *default-log-port* "sub megatest " action-switches-str " completed with exit code " exit-code)
+              (if (eq? 0 exit-code)
+                  (begin
+                    #t)
+                  (begin
+                    #f))))))))
+
+
+
+;; (subrun:exec-sub-megatest "/nfs/pdx/disks/icf_env_disk001/bjbarcla/gwa/issues/mtdev/165/megatest/ext-tests/tests/subrun-usecases/toparea/links/SYSTEM_val/RELEASE_val/go/toptest" "-foo" "foo")

Index: synchash.scm
==================================================================
--- synchash.scm
+++ synchash.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 .
+;;
 ;;======================================================================
 
 ;;======================================================================
 ;; A hash of hashes that can be kept in sync by sending minial deltas
 ;;======================================================================

Index: tasks.scm
==================================================================
--- tasks.scm
+++ tasks.scm
@@ -1,13 +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')
 
 (use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking format)
 (import (prefix sqlite3 sqlite3:))
@@ -36,24 +45,24 @@
 	(handle-exceptions
 	 exn
 	 (begin
 	   (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* " exn=" (condition->list exn))
+	   (debug:print 5 *default-log-port* " exn=" (condition->list exn))
 	   (debug:print 0 *default-log-port* "tasks:wait-on-journal failed. Continuing on, you can ignore this call-chain")
 	   #t) ;; if stuff goes wrong just allow it to move on
-	 (let loop ((journal-exists (file-exists? fullpath))
+	 (let loop ((journal-exists (common:file-exists? fullpath))
 		    (count          n)) ;; wait ten times ...
 	   (if journal-exists
 	       (begin
 		 (if (and waiting-msg
 			  (eq? (modulo n 30) 0))
 		     (debug:print 0 *default-log-port* waiting-msg))
 		 (if (> count 0)
 		     (begin
 		       (thread-sleep! 1)
-		       (loop (file-exists? fullpath)
+		       (loop (common:file-exists? fullpath)
 			     (- count 1)))
 		     (begin
 		       (debug:print 0 *default-log-port* "ERROR: removing the journal file " fullpath ", this is not good. Look for disk full, write access and other issues.")
 		       (if remove (system (conc "rm -rf " fullpath)))
 		       #f)))
@@ -87,21 +96,21 @@
        exn
        (if (> numretries 0)
 	   (begin
 	     (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* " exn=" (condition->list exn))
+	     (debug:print 5 *default-log-port* " exn=" (condition->list exn))
 	     (thread-sleep! 1)
 	     (tasks:open-db numretries (- numretries 1)))
 	   (begin
 	     (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* " exn=" (condition->list exn))))
+	     (debug:print 5 *default-log-port* " exn=" (condition->list exn))))
        (let* ((dbpath        (db:dbfile-path )) ;; (tasks:get-task-db-path))
 	      (dbfile       (conc dbpath "/monitor.db"))
 	      (avail        (tasks:wait-on-journal dbpath 10)) ;; wait up to about 10 seconds for the journal to go away
-	      (exists       (file-exists? dbpath))
+	      (exists       (common:file-exists? dbpath))
 	      (write-access (file-write-access? dbpath))
 	      (mdb          (cond ;; what the hek is *toppath* doing here?
 			     ((and (string? *toppath*)(file-write-access? *toppath*))
 			      (sqlite3:open-database dbfile))
 			     ((file-read-access? dbpath)    (sqlite3:open-database dbfile))
@@ -183,15 +192,27 @@
 ;; no elegance here ...
 ;;
 (define (tasks:kill-server hostname pid #!key (kill-switch ""))
   (debug:print-info 0 *default-log-port* "Attempting to kill server process " pid " on host " hostname)
   (setenv "TARGETHOST" hostname)
-  (setenv "TARGETHOST_LOGF" "server-kills.log")
-  (system (conc "nbfake kill "kill-switch" "pid))
+  (let* ((logdir (if (directory-exists? "logs")
+                    "logs/"
+                    ""))
+         (logfile (if logdir (conc "logs/server-"pid"-"hostname".log") #f))
+         (gzfile  (if logfile (conc logfile ".gz"))))
+    (setenv "TARGETHOST_LOGF" (conc logdir "server-kills.log"))
+
+    (system (conc "nbfake kill "kill-switch" "pid))
 
-  (unsetenv "TARGETHOST_LOGF")
-  (unsetenv "TARGETHOST"))
+    (when logfile
+      (thread-sleep! 0.5)
+      (if (common:file-exists? gzfile) (delete-file gzfile))
+      (system (conc "gzip " logfile))
+      
+      (unsetenv "TARGETHOST_LOGF")
+      (unsetenv "TARGETHOST"))))
+    
  
 ;;======================================================================
 ;; M O N I T O R S
 ;;======================================================================
 
@@ -606,63 +627,271 @@
 	  (case modifier
 	    ((none)(loop (conc (current-user-name) "_" area-name) 'user))
 	    ((user)(loop (conc (substring (common:get-area-path-signature) 0 4)
 			       area-name) 'areasig))
 	    (else #f)))))) ;; give up
+
+(define (task:print-runtime run-times saperator)
+(for-each
+    (lambda (run-time-info)
+     (let* ((run-name  (vector-ref run-time-info 0))
+            (run-time  (vector-ref run-time-info 1))
+            (target  (vector-ref run-time-info 2)))
+        (print target saperator run-name saperator run-time )))
+   run-times))
+
+(define (task:print-runtime-as-json run-times)
+ (let loop ((run-time-info (car run-times))
+            (rema (cdr run-times)) 
+            (str ""))
+     (let* ((run-name  (vector-ref run-time-info 0))
+            (run-time  (vector-ref run-time-info 1))
+            (target  (vector-ref run-time-info 2)))
+        ;(print (not (equal? str "")))
+        (if (not (equal? str "")) 
+            (set! str (conc str ",")))
+        (if (null? rema)
+		(print "[" str "{target:" target ",run-name:" run-name ", run-time:" run-time "}]")
+            (loop (car rema) (cdr rema) (conc str "{target:" target ", run-name:" run-name ", run-time:" run-time "}"))))))
+
+(define (task:get-run-times)
+   (let* ( 
+           (run-patt (if (args:get-arg "-run-patt")
+                        (args:get-arg "-run-patt")
+                        "%"))
+           (target-patt (if (args:get-arg "-target-patt")
+                        (args:get-arg "-target-patt")
+                        "%"))
+ 
+           (run-times  (rmt:get-run-times  run-patt target-patt )))
+   (if (eq? (length run-times) 0)
+     (begin
+       (print "Data not found!!")
+       (exit)))
+   (if (equal? (args:get-arg "-dumpmode") "json")
+       (task:print-runtime-as-json run-times)
+         (if (equal? (args:get-arg "-dumpmode") "csv")
+	     (task:print-runtime run-times ",")
+	     (task:print-runtime run-times "  ")))))
+
+
+(define (task:print-testtime test-times saperator)
+(for-each
+    (lambda (test-time-info)
+     (let* ((test-name  (vector-ref test-time-info 0))
+            (test-time  (vector-ref test-time-info 2))
+            (test-item  (if (eq? (string-length (vector-ref test-time-info 1)) 0)
+                               "N/A"
+				(vector-ref test-time-info 1))))
+        (print  test-name saperator test-item saperator test-time )))
+   test-times))
+
+(define (task:print-testtime-as-json test-times)
+ (let loop ((test-time-info (car test-times))
+            (rema (cdr test-times)) 
+            (str ""))
+     (let* ((test-name  (vector-ref test-time-info 0))
+            (test-time  (vector-ref test-time-info 2))
+            (item  (vector-ref test-time-info 1)))
+        ;(print (not (equal? str "")))
+        (if (not (equal? str "")) 
+            (set! str (conc str ",")))
+        (if (null? rema)
+		(print "[" str "{test-name:" test-name ", item-path:" item ", test-time:" test-time "}]")
+            (loop (car rema) (cdr rema) (conc str "{test-name:" test-name ", item-path:" item ", test-time:" test-time "}"))))))
+
+
+ (define (task:get-test-times)
+   (let* ((runname (if (args:get-arg "-runname")
+                        (args:get-arg "-runname")
+                        #f))
+           (target (if (args:get-arg "-target")
+                        (args:get-arg "-target")
+                        #f))
+ 
+           (test-times  (rmt:get-test-times  runname target )))
+   (if (not runname)
+      (begin
+      (print "Error: Missing argument -runname")
+      (exit))) 
+    (if (string-contains runname "%")
+      (begin
+      (print "Error: Invalid runname, '%' not allowed  (" runname ") ")
+      (exit)))
+    (if (not target)
+      (begin
+      (print "Error: Missing argument -target")
+      (exit)))
+     (if  (string-contains target "%")
+      (begin
+      (print "Error: Invalid target, '%' not allowed  (" target ") ")
+      (exit)))
+ 
+   (if (eq? (length test-times) 0)
+     (begin
+       (print "Data not found!!")
+       (exit)))
+   (if (equal? (args:get-arg "-dumpmode") "json")
+       (task:print-testtime-as-json test-times)
+         (if (equal? (args:get-arg "-dumpmode") "csv")
+	     (task:print-testtime test-times ",")
+	     (task:print-testtime test-times "  ")))))
+
+
 
 ;; gets mtpg-run-id and syncs the record if different
 ;;
-(define (tasks:run-id->mtpg-run-id dbh cached-info run-id)
+(define (tasks:run-id->mtpg-run-id dbh cached-info run-id area-info)
   (let* ((runs-ht (hash-table-ref cached-info 'runs))
-	 (runinf  (hash-table-ref/default runs-ht run-id #f)))
-    (if runinf
+	 (runinf  (hash-table-ref/default runs-ht run-id #f))
+         (area-id (vector-ref area-info 0)))
+       (if runinf
 	runinf ;; already cached
 	(let* ((run-dat    (rmt:get-run-info run-id))               ;; NOTE: get-run-info returns a vector < row header >
 	       (run-name   (rmt:get-run-name-from-id run-id))
 	       (row        (db:get-rows run-dat))                   ;; yes, this returns a single row
 	       (header     (db:get-header run-dat))
-	       (state      (db:get-value-by-header row header "state "))
+	       (state      (db:get-value-by-header row header "state"))
 	       (status     (db:get-value-by-header row header "status"))
 	       (owner      (db:get-value-by-header row header "owner"))
 	       (event-time (db:get-value-by-header row header "event_time"))
 	       (comment    (db:get-value-by-header row header "comment"))
 	       (fail-count (db:get-value-by-header row header "fail_count"))
 	       (pass-count (db:get-value-by-header row header "pass_count"))
-	       (contour    (if (args:get-arg "-prepend-contour") (db:get-value-by-header row header "contour")))
+               (db-contour (db:get-value-by-header row header "contour"))
+	       (contour    (if (args:get-arg "-prepend-contour") 
+                                 (if (and db-contour (not (equal? db-contour ""))) 
+                                           (begin 
+                                            (print "db-contour") 
+ 						db-contour)
+					    (args:get-arg "-contour"))))
 	       (keytarg    (if (or (args:get-arg "-prepend-contour") (args:get-arg "-prefix-target"))
 	       			(conc "MT_CONTOUR/MT_AREA/" (string-intersperse (rmt:get-keys) "/")) (string-intersperse (rmt:get-keys) "/"))) ;; e.g. version/iteration/platform
 	       (target     (if (or (args:get-arg "-prepend-contour") (args:get-arg "-prefix-target")) 
 	       			(conc (or (args:get-arg "-prefix-target") (conc contour "/" (common:get-area-name) "/")) (rmt:get-target run-id)) (rmt:get-target run-id)))                 ;; e.g. v1.63/a3e1/ubuntu
 	       (spec-id    (pgdb:get-ttype dbh keytarg))
-	       (new-run-id (pgdb:get-run-id dbh spec-id target run-name))
-
-
-
+	       (new-run-id (pgdb:get-run-id dbh spec-id target run-name area-id))
 	       ;; (area-id    (db:get-value-by-header row header "area_id)"))
 	       )
-	  (if new-run-id
+              (if new-run-id
 	      (begin ;; let ((run-record (pgdb:get-run-info dbh new-run-id))
 		(hash-table-set! runs-ht run-id new-run-id)
 		;; ensure key fields are up to date
 		(pgdb:refresh-run-info
 		 dbh
 		 new-run-id
-		 state status owner event-time comment fail-count pass-count)
+		 state status owner event-time comment fail-count pass-count area-id)
 		new-run-id)
-	      (if (handle-exceptions
+	      (if (equal? state "deleted")
+                 (begin 
+                 (print "Warning: Run with id " run-id " was created after previous sync and deleted before the sync") #f)
+               (if (handle-exceptions
 		      exn
-		      (begin (print-call-chain) #f)
-		    (pgdb:insert-run
+		      (begin (print-call-chain)
+                              (print ((condition-property-accessor 'exn 'message) exn))     
+			#f)
+                     
+                     (pgdb:insert-run
 		     dbh
-		     spec-id target run-name state status owner event-time comment fail-count pass-count)) ;; area-id))
-		  (tasks:run-id->mtpg-run-id dbh cached-info run-id)
-		  #f))))))
+		     spec-id target run-name state status owner event-time comment fail-count pass-count  area-id))
+		       (tasks:run-id->mtpg-run-id dbh cached-info run-id area-info)
+		  #f)))))))
+
+
+(define (tasks:sync-test-steps dbh cached-info test-step-ids)
+  (print "Sync Steps " test-step-ids )
+  (let ((test-ht (hash-table-ref cached-info 'tests))
+        (step-ht (hash-table-ref cached-info 'steps)))
+    (for-each
+     (lambda (test-step-id)
+        (let* ((test-step-info  (rmt:get-steps-info-by-id test-step-id))
+               (step-id (tdb:step-get-id test-step-info))
+               (test-id  (tdb:step-get-test_id    test-step-info))   
+	       (stepname (tdb:step-get-stepname  test-step-info))
+	       (state (tdb:step-get-state test-step-info))	
+	       (status (tdb:step-get-status test-step-info))	
+	       (event_time (tdb:step-get-event_time  test-step-info))	
+	       (comment  (tdb:step-get-comment test-step-info))	
+	       (logfile (tdb:step-get-logfile test-step-info))	
+	       (pgdb-test-id  (hash-table-ref/default test-ht test-id #f))
+               (pgdb-step-id (if pgdb-test-id 
+                                 (pgdb:get-test-step-id dbh pgdb-test-id stepname state)
+                                  #f)))
+    (if step-id
+      (begin  
+        (if pgdb-test-id
+           (begin 
+                (if  pgdb-step-id
+                   (begin
+                    (print "Updating existing test-step with test-id: " test-id " and step-id " step-id " pgdb test id: " pgdb-test-id )
+                    (pgdb:update-test-step dbh pgdb-step-id pgdb-test-id stepname state status event_time comment logfile))
+                    (begin
+ 		      (print "Inserting test-step with test-id: " test-id " and step-id " step-id  " pgdb test id: " pgdb-test-id)
+                      (pgdb:insert-test-step dbh pgdb-test-id stepname state status event_time comment logfile )
+                      (set! pgdb-step-id  (pgdb:get-test-step-id dbh pgdb-test-id stepname state))))
+                (hash-table-set! step-ht step-id pgdb-step-id ))
+           (print "Error: Test not cashed")))
+      (print "Error: Could not get test step info for step id " test-step-id ))))	;; this is a wierd senario need to debug      	
+   test-step-ids)))
+
+(define (tasks:sync-test-gen-data dbh cached-info test-data-ids)
+  (let ((test-ht (hash-table-ref cached-info 'tests))
+        (data-ht (hash-table-ref cached-info 'data)))
+    (for-each
+     (lambda (test-data-id)
+        (let* ((test-data-info  (rmt:get-data-info-by-id test-data-id))
+               (data-id (db:test-data-get-id  test-data-info))
+               (test-id  (db:test-data-get-test_id   test-data-info))   
+	       (category  (db:test-data-get-category  test-data-info))
+	       (variable  (db:test-data-get-variable test-data-info))	
+	       (value (db:test-data-get-value  test-data-info))	
+               (expected (db:test-data-get-expected  test-data-info))
+               (tol (db:test-data-get-tol  test-data-info))
+               (units (db:test-data-get-units  test-data-info))     
+	       (comment  (db:test-data-get-comment test-data-info))	
+               (status (db:test-data-get-status test-data-info))	
+	       (type (db:test-data-get-type test-data-info))	
+	       (pgdb-test-id  (hash-table-ref/default test-ht test-id #f))
+               (pgdb-data-id (if pgdb-test-id 
+                                 (pgdb:get-test-data-id dbh pgdb-test-id category variable)
+                                  #f)))
+    (if data-id
+      (begin
+        (if pgdb-test-id
+           (begin 
+                (if  pgdb-data-id
+                   (begin
+                    (print "Updating existing test-data with test-id: " test-id " and  data-id " data-id " pgdb test id: " pgdb-test-id)
+                    (pgdb:update-test-data dbh pgdb-data-id pgdb-test-id  category variable value expected tol units comment status type))
+                    (begin
+ 		      (print "Inserting test-data with test-id: " test-id " and data-id " data-id " pgdb test id: " pgdb-test-id)
+                       (if (handle-exceptions
+		      exn
+		      (begin (print-call-chain)
+                              (print ((condition-property-accessor 'exn 'message) exn))     
+			#f)
+                     
+                    (pgdb:insert-test-data dbh pgdb-test-id category variable value expected tol units comment status type ))
+		       ;(tasks:run-id->mtpg-run-id dbh cached-info run-id area-info)
+                      (begin
+                      ;(pgdb:insert-test-data dbh pgdb-test-id category variable value expected tol units comment status type )
+                      (set! pgdb-data-id  (pgdb:get-test-data-id dbh pgdb-test-id  category variable)))
+		  (exit))))
+                (hash-table-set! data-ht data-id pgdb-data-id ))
+             (begin
+                 (print "Error: Test not in pgdb"))))
+
+      (print "Error: Could not get test data info for data id " test-data-id ))))	;; this is a wierd senario need to debug      	
+   test-data-ids)))
+
+
 
-(define (tasks:sync-tests-data dbh cached-info test-ids)
+(define (tasks:sync-tests-data dbh cached-info test-ids area-info)
   (let ((test-ht (hash-table-ref cached-info 'tests)))
     (for-each
      (lambda (test-id)
+       ;(print test-id)
        (let* ((test-info    (rmt:get-test-info-by-id #f test-id))
 	      (run-id       (db:test-get-run_id    test-info)) ;; look these up in db_records.scm
 	      (test-id      (db:test-get-id        test-info))
 	      (test-name    (db:test-get-testname  test-info))
 	      (item-path    (db:test-get-item-path test-info))
@@ -676,24 +905,55 @@
 	      (log-file     (db:test-get-final_logf test-info))
 	      (run-duration (db:test-get-run_duration test-info))
 	      (comment      (db:test-get-comment   test-info))
 	      (event-time   (db:test-get-event_time test-info))
 	      (archived     (db:test-get-archived  test-info))
-	      (pgdb-run-id  (tasks:run-id->mtpg-run-id dbh cached-info run-id))
-	      (pgdb-test-id (pgdb:get-test-id dbh pgdb-run-id test-name item-path)))
+	      (pgdb-run-id  (tasks:run-id->mtpg-run-id dbh cached-info run-id area-info))
+                
+	      (pgdb-test-id (if pgdb-run-id 
+				(begin
+                                  ;(print pgdb-run-id)    
+                                 (pgdb:get-test-id dbh pgdb-run-id test-name item-path))
+                                 #f)))
 	 ;; "id"           "run_id"        "testname"  "state"      "status"      "event_time"
 	 ;; "host"         "cpuload"       "diskfree"  "uname"      "rundir"      "item_path"
 	 ;; "run_duration" "final_logf"    "comment"   "shortdir"   "attemptnum"  "archived"
-	 (if pgdb-test-id ;; have a record
+         (if pgdb-run-id
+           (begin
+	   (if pgdb-test-id ;; have a record
 	     (begin ;; let ((key-name (conc run-id "/" test-name "/" item-path)))
-	       (hash-table-set! test-ht test-id pgdb-test-id)
-	       (print "Updating existing test with run-id: " run-id " and test-id: " test-id)
+	       (print "Updating existing test with run-id: " run-id " and test-id: " test-id " pgdb run id: " pgdb-run-id)
 	       (pgdb:update-test dbh pgdb-test-id pgdb-run-id test-name item-path state status host cpuload diskfree uname run-dir log-file run-duration comment event-time archived))
-	     (pgdb:insert-test dbh pgdb-run-id test-name item-path state status host cpuload diskfree uname run-dir log-file run-duration comment event-time archived))
-	 ))
+	     (begin 
+                 (print "Inserting test with run-id: " run-id " and test-id: " test-id  " pgdb run id: " pgdb-run-id)
+                (pgdb:insert-test dbh pgdb-run-id test-name item-path state status host cpuload diskfree uname run-dir log-file run-duration comment event-time archived)
+                (set! pgdb-test-id (pgdb:get-test-id dbh pgdb-run-id test-name item-path))))
+               (hash-table-set! test-ht test-id pgdb-test-id))
+              (print "WARNING: Skipping run with run-id:" run-id ". This run was created after privious sync and removed before this sync."))))
      test-ids)))
 
+(define (task:add-area-tag dbh area-info tag) 
+  (let* ((tag-info (pgdb:get-tag-info-by-name dbh tag)))
+   (if (not tag-info)
+     (begin   
+     (if (handle-exceptions
+	   exn
+	   (begin 
+               (print ((condition-property-accessor 'exn 'message) exn))     
+	   #f)
+	   (pgdb:insert-tag  dbh   tag))
+                       (set! tag-info (pgdb:get-tag-info-by-name dbh tag))
+		  #f)))
+     ;;add to area_tags
+     (handle-exceptions
+	   exn
+	   (begin 
+               (print ((condition-property-accessor 'exn 'message) exn))     
+	   #f)
+           (if (not (pgdb:is-area-taged-with-a-tag dbh (vector-ref tag-info 0)  (vector-ref area-info 0)))  
+	   (pgdb:insert-area-tag  dbh   (vector-ref tag-info 0)  (vector-ref area-info 0))))))
+
 ;; get runs changed since last sync
 ;; (define (tasks:sync-test-data dbh cached-info area-info)
 ;;   (let* ((
 
 (define (tasks:sync-to-postgres configdat dest)
@@ -701,27 +961,39 @@
 	 (area-info   (pgdb:get-area-by-path dbh *toppath*))
 	 (cached-info (make-hash-table))
 	 (start       (current-seconds)))
     (for-each (lambda (dtype)
 		(hash-table-set! cached-info dtype (make-hash-table)))
-	      '(runs targets tests))
+	      '(runs targets tests steps data))
     (hash-table-set! cached-info 'start start) ;; when done we'll set sync times to this
     (if area-info
 	(let* ((last-sync-time (vector-ref area-info 3))
 	       (changed        (rmt:get-changed-record-ids last-sync-time))
 	       (run-ids        (alist-ref 'runs       changed))
 	       (test-ids       (alist-ref 'tests      changed))
 	       (test-step-ids  (alist-ref 'test_steps changed))
 	       (test-data-ids  (alist-ref 'test_data  changed))
-	       (run-stat-ids   (alist-ref 'run_stats  changed)))
-	  (print "area-info: " area-info)
+	       (run-stat-ids   (alist-ref 'run_stats  changed))
+               (area-tag    (if (args:get-arg "-area-tag") 
+                                 (args:get-arg "-area-tag")
+                                  "")))
+	 ; (print "area-info: " area-info)
+           (if (and (equal? area-tag "") (not (pgdb:is-area-taged dbh (vector-ref area-info 0))))
+            (set! area-tag *default-area-tag*)) 
+           (if (not (equal? area-tag "")) 
+             (task:add-area-tag dbh area-info area-tag)) 
 	  (if (not (null? test-ids))
 	      (begin
-		(print "Syncing " (length test-ids) " changed tests")
-		(tasks:sync-tests-data dbh cached-info test-ids)))
+		(print "Syncing " (length test-step-ids) " changed tests")
+                ;;Assumption here is that if test-step or test data is changed then the test last update time is changed 
+                ;; not syncing run stats at this time as they can be derived from tests table.
+		(tasks:sync-tests-data dbh cached-info test-ids area-info)
+                ;(exit)   
+                (tasks:sync-test-steps dbh cached-info test-step-ids)
+                (tasks:sync-test-gen-data dbh cached-info test-data-ids)))
 	  (pgdb:write-sync-time dbh area-info start))
 	(if (tasks:set-area dbh configdat)
 	    (tasks:sync-to-postgres configdat dest)
 	    (begin
 	      (debug:print 0 *default-log-port* "ERROR: unable to create an area record")
 	      #f)))))
 

ADDED   tcmt.scm
Index: tcmt.scm
==================================================================
--- /dev/null
+++ tcmt.scm
@@ -0,0 +1,339 @@
+;; Copyright 2006-2017, 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.
+;;
+;;======================================================================
+;;
+;; Wrapper to enable running Megatest flows under teamcity
+;;
+;;  1. Run the megatest process and pass it all the needed parameters
+;;  2. Every five seconds check for state/status changes and print the info
+;;
+
+(use srfi-1 posix srfi-69 srfi-18 regex defstruct)
+
+(use trace)
+;; (trace-call-sites #t)
+
+(declare (uses margs))
+(declare (uses rmt))
+(declare (uses common))
+(declare (uses megatest-version))
+
+(include "megatest-fossil-hash.scm")
+(include "db_records.scm")
+
+(define origargs (cdr (argv)))
+(define remargs (args:get-args
+		 (argv)
+		 `( "-target"
+		    "-reqtarg"
+		    "-runname"
+		    "-delay"   ;; how long to wait for unexpected changes to 
+		    )
+		 `("-tc-repl"
+		   )
+		 args:arg-hash
+		 0))
+
+(defstruct testdat
+  (tc-type #f)
+  (state   #f)
+  (status  #f)
+  (overall #f)
+  (flowid  #f)
+  tctname
+  tname
+  (event-time #f)
+  details
+  comment
+  duration
+  (start-printed #f)
+  (end-printed   #f))
+
+;;======================================================================
+;; GLOBALS
+;;======================================================================
+
+;; Gotta have a global? Stash it in the *global* hash table.
+;;
+(define *global* (make-hash-table))
+
+(define (tcmt:print tdat flush-mode)
+  (let* ((comment  (if (testdat-comment tdat)
+		       (conc " message='" (testdat-comment tdat) "'")
+		       ""))
+	 (details  (if (testdat-details tdat)
+		       (conc " details='" (testdat-details tdat) "'")
+		       ""))
+	 (flowid   (conc " flowId='" (testdat-flowid   tdat) "'"))
+	 (duration (conc " duration='" (* 1e3 (testdat-duration tdat)) "'"))
+	 (tcname   (conc " name='" (testdat-tctname  tdat) "'"))
+	 (state    (string->symbol (testdat-state tdat)))
+	 (status   (string->symbol (testdat-status tdat)))
+	 (startp   (testdat-start-printed tdat))
+	 (endp     (testdat-end-printed   tdat))
+	 (etime    (testdat-event-time    tdat))
+	 (overall  (case state
+		     ((RUNNING)   state)
+		     ((COMPLETED) state)
+		     (else 'UNK)))
+	 (tstmp    (conc " timestamp='" (time->string (seconds->local-time etime) "%FT%T.000") "'")))
+    (case overall
+      ((RUNNING)
+       (if (not startp)
+	   (begin
+	     (print "##teamcity[testStarted "  tcname flowid tstmp "]")
+	     (testdat-start-printed-set! tdat #t))))
+      ((COMPLETED)
+       (if (not startp) ;; start stanza never printed
+	   (begin
+	     (print "##teamcity[testStarted " tcname flowid tstmp "]")
+	     (testdat-start-printed-set! tdat #t)))
+       (if (not endp)
+	   (begin
+	     (if (not (member status '(PASS WARN SKIP WAIVED)))
+		 (print "##teamcity[testFailed  " tcname flowid comment details "]"))
+             (print "##teamcity[testFinished" tcname flowid comment details duration "]")
+	     (testdat-end-printed-set! tdat #t))))
+      (else
+       (if flush-mode
+	   (begin
+	     (if (not startp)
+		 (begin
+		   (print "##teamcity[testStarted " tcname flowid tstmp "]")
+		   (testdat-start-printed-set! tdat #t)))
+	     (if (not endp)
+		 (begin
+		   (print "##teamcity[testFailed  " tcname flowid comment details "]")
+                   (print "##teamcity[testFinished" tcname flowid comment details duration "]")
+		   (testdat-end-printed-set! tdat #t)))))))
+    ;; (print "ERROR: tc-type \"" (testdat-tc-type tdat) "\" not recognised for " tcname)))
+    (flush-output)))
+
+;; ;; returns values: flag newlst
+;; (define (remove-duplicate-completed  tdats)
+;;   (let* ((flag       #f)
+;;          (state      (testdat-state      tdat))
+;;          (status     (testdat-status     tdat))
+;;          (event-time (testdat-event-time tdat))
+;;          (tname      (testdat-tname      tdat)))
+;;     (let loop ((hed (car tdats))
+;;                (tal (cdr tdats))
+;;                (new '()))
+;;       (if (and (equal? state "COMPLETED")
+;;                (equal? tname (testdat-tname hed))
+;;                (equal? state (testdat-state hed))) ;; we have a duplicate COMPLETED call
+;;           (begin
+;;             (set! flag #t) ;; A changed completed
+            
+;; process the queue of tests gathered so far. List includes one entry for every test so far seen
+;; the last record for a test is preserved. Items are only removed from the list if over 15 seconds
+;; have passed since it happened. This allows for compression of COMPLETED/FAIL followed by some other
+;; state/status
+;;
+(define (process-queue data age flush-mode)
+  ;; here we process tqueue and gather those over 15 seconds (configurable?) old
+  (let* ((print-time (- (current-seconds) age)) ;; print stuff over 15 seconds old
+         (tqueue-raw (hash-table-ref/default data 'tqueue '()))
+         (tqueue     (reverse (delete-duplicates tqueue-raw     ;; REMOVE duplicates by testname and state
+                                                 (lambda (a b)
+                                                   (and (equal? (testdat-tname a)(testdat-tname b))        ;; need oldest to newest
+                                                        (equal? (testdat-state a) (testdat-state b)))))))) ;; "COMPLETED")
+    ;; (equal? (testdat-state b) "COMPLETED")))))))
+    (if (not (null? tqueue))
+        (hash-table-set!
+         data
+         'tqueue
+         (let loop ((hed (car tqueue)) ;; by this point all duplicates by state COMPLETED are removed
+                    (tal (cdr tqueue))
+                    (rem '()))
+           (if (> print-time (testdat-event-time hed)) ;; event happened over 15 seconds ago
+               (begin
+                 (tcmt:print hed flush-mode)
+                 (if (null? tal)
+                     rem ;; return rem to be processed in the future
+                     (loop (car tal)(cdr tal) rem)))
+               (if (null? tal)
+                   (cons hed rem) ;; return rem + hed for future processing
+                   (loop (car tal)(cdr tal)(cons hed rem)))))))))
+
+                            ;; ##teamcity[testStarted name='suite.testName']
+;; ##teamcity[testStdOut name='suite.testName' out='text']
+;; ##teamcity[testStdErr name='suite.testName' out='error text']
+;; ##teamcity[testFailed name='suite.testName' message='failure message' details='message and stack trace']
+;; ##teamcity[testFinished name='suite.testName' duration='50']
+;; 
+;; flush; #f, normal call. #t, last call, print out something for NOT_STARTED, etc.
+;;
+
+;;;;;;;   (begin
+;;;;;;;     (case (string->symbol newstat)
+;;;;;;;       ((UNK)       ) ;; do nothing
+;;;;;;;       ((RUNNING)   (print "##teamcity[testStarted name='" tctname "' flowId='" flowid "']"))
+;;;;;;;       ((PASS SKIP WARN WAIVED) (print "##teamcity[testFinished name='" tctname "' duration='" (* 1e3 duration) "'" cmtstr details " flowId='" flowid "']"))
+;;;;;;;       (else
+;;;;;;; 	(print "##teamcity[testFailed name='" tctname "' " cmtstr details " flowId='" flowid "']")))
+;;;;;;;     (flush-output)
+
+;; (trace rmt:get-tests-for-run)
+
+(define (update-queue-since data run-ids last-update tsname target runname flowid flush) ;; 
+  (let ((now   (current-seconds)))
+;; (handle-exceptions
+;; 	exn
+;; 	(begin (print-call-chain) (print "Error message: " ((condition-property-accessor 'exn 'message) exn)))
+      (for-each
+       (lambda (run-id)
+	 (let* ((tests (rmt:get-tests-for-run run-id "%" '() '() #f #f #f #f #f #f last-update #f)))
+	   ;; (print "DEBUG: got tests=" tests)
+	   (for-each
+	    (lambda (test-rec)
+	      (let* ((tqueue   (hash-table-ref/default data 'tqueue '())) ;; NOTE: the key is a symbol! This allows keeping disparate info in the one hash, lazy but a quick solution for right now.
+		     (is-top   (db:test-get-is-toplevel  test-rec))
+		     (tname    (db:test-get-fullname     test-rec))
+		     (testname (db:test-get-testname     test-rec))
+		     (itempath (db:test-get-item-path    test-rec))
+		     (tctname  (if (string=? itempath "") testname (conc testname "." (string-translate itempath "/" "."))))
+		     (state    (db:test-get-state        test-rec))
+		     (status   (db:test-get-status       test-rec))
+		     (etime    (db:test-get-event_time   test-rec))
+		     (duration (or (any->number (db:test-get-run_duration test-rec)) 0))
+		     (comment  (db:test-get-comment      test-rec))
+		     (logfile  (db:test-get-final_logf   test-rec))
+                     (hostn    (db:test-get-host         test-rec))
+                     (pid      (db:test-get-process_id   test-rec))
+		     (newstat  (cond
+				((equal? state "RUNNING")   "RUNNING")
+				((equal? state "COMPLETED") status)
+				(flush   (conc state "/" status))
+				(else "UNK")))
+		     (cmtstr   (if (and (not flush) comment)
+				   comment
+				   (if flush
+				       (conc "Test ended in state/status=" state "/" status  (if  (string-match "^\\s*$" comment)
+												  ", no Megatest comment found."
+												  (conc ", Megatest comment=\"" comment "\""))) ;; special case, we are handling stragglers
+				       #f)))
+		     (details  (if (string-match ".*html$" logfile)
+				   (conc *toppath* "/lt/" target "/" runname "/" testname (if (equal? itempath "") "/" (conc "/" itempath "/")) logfile)
+				   #f))
+		     (prev-tdat (hash-table-ref/default data tname #f)) 
+		     (tdat      (if is-top
+				    #f
+				    (let ((new (or prev-tdat (make-testdat)))) ;; recycle the record so we keep track of already printed items
+				      (testdat-flowid-set!     new (or (testdat-flowid new)
+                                                                       (if (eq? pid 0)
+                                                                           tctname
+                                                                           (conc hostn "-" pid))))
+				      (testdat-tctname-set!    new tctname)
+				      (testdat-tname-set!      new tname)
+				      (testdat-state-set!      new state)
+				      (testdat-status-set!     new status)
+				      (testdat-comment-set!    new cmtstr)
+				      (testdat-details-set!    new details)
+				      (testdat-duration-set!   new duration)
+				      (testdat-event-time-set! new etime) ;; (current-seconds))
+				      (testdat-overall-set!    new newstat)
+				      (hash-table-set! data tname new)
+				      new))))
+		(if (not is-top)
+		    (hash-table-set! data 'tqueue (cons tdat tqueue)))
+                (hash-table-set! data tname tdat)
+                ))
+            tests)))
+       run-ids)
+      now))
+      
+(define (monitor pid)
+  (let* ((run-ids '())
+	 (testdats (make-hash-table))  ;; each entry is a list of testdat structs
+	 (keys    #f)
+	 (last-update 0)
+	 (target  (or (args:get-arg "-target")
+		      (args:get-arg "-reqtarg")))
+	 (runname (args:get-arg "-runname"))
+	 (tsname  #f)
+	 (flowid  (conc target "/" runname))
+	 (tdelay  (string->number (or (args:get-arg "-delay") "15"))))
+    (if (and target runname)
+	(begin
+	  (launch:setup)
+	  (set! keys (rmt:get-keys))))
+    (set! tsname  (common:get-testsuite-name))
+    (print "TCMT: for testsuite=" tsname " found runname=" runname ", target=" target ", keys=" keys " and successfully ran launch:setup. Using " flowid " as the flowId.")
+    (let loop ()
+      ;;;;;; (handle-exceptions
+      ;;;;;;  exn
+      ;;;;;;  ;; (print "Process done.")
+      ;;;;;;  (begin (print-call-chain) (print "Error message: " ((condition-property-accessor 'exn 'message) exn)))
+       (let-values (((pidres exittype exitstatus)
+		     (process-wait pid #t)))
+	 (if (and keys
+		  (or (not run-ids)
+		      (null? run-ids)))
+	     (let* ((runs (rmt:get-runs-by-patt keys
+						runname 
+						target
+						#f ;; offset
+						#f ;; limit
+						#f ;; fields
+						0  ;; last-update
+						))
+		    (header (db:get-header runs))
+		    (rows   (db:get-rows   runs))
+		    (run-ids-in (map (lambda (row)
+				       (db:get-value-by-header row header "id"))
+				     rows)))
+	       (set! run-ids run-ids-in)))
+	 ;; (print "TCMT: pidres=" pidres " exittype=" exittype " exitstatus=" exitstatus " run-ids=" run-ids)
+	 (if (eq? pidres 0)
+	     (begin
+	       (if keys
+                   (begin
+                     (set! last-update (- (update-queue-since testdats run-ids last-update tsname target runname flowid #f) 5))
+                     (process-queue testdats tdelay #f)))
+               (thread-sleep! 3)
+	       (loop))
+	     (begin
+	       ;; (print "TCMT: pidres=" pidres " exittype=" exittype " exitstatus=" exitstatus " run-ids=" run-ids)
+	       (print "TCMT: processing any tests that did not formally complete.")
+	       (update-queue-since testdats run-ids 0 tsname target runname flowid #t) ;; call in flush mode
+               (process-queue testdats 0 #t)
+	       (print "TCMT: All done.")
+	       ))))))
+;;;;; )
+
+;; (trace print-changes-since)
+
+;; (if (not (eq? pidres 0))	  ;; (not exitstatus))
+;; 	  (begin
+;; 	    (thread-sleep! 3)
+;; 	    (loop))
+;; 	  (print "Process: megatest " (string-intersperse origargs " ") " is done.")))))
+(define (main)
+  (let* ((mt-done #f)
+	 (pid     #f)
+	 (th1     (make-thread (lambda ()
+				 (print "Running megatest " (string-intersperse origargs " "))
+				 (set! pid (process-run "megatest" origargs)))
+			       "Megatest job"))
+	 (th2     (make-thread (lambda ()
+				 (monitor pid))
+			       "Monitor job")))
+    (thread-start! th1)
+    (thread-sleep! 1) ;; give the process time to get going
+    (thread-start! th2)
+    (thread-join! th2)))
+
+(if (args:get-arg "-tc-repl")
+    (repl)
+    (main))
+
+;; (process-wait)
+

Index: tdb.scm
==================================================================
--- tdb.scm
+++ tdb.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 .
+;;
 ;;======================================================================
 
 ;;======================================================================
 ;; Database access
 ;;======================================================================
@@ -50,11 +59,11 @@
   (debug:print-info 11 *default-log-port* "open-test-db " work-area)
   (if (and work-area 
 	   (directory? work-area)
 	   (file-read-access? work-area))
       (let* ((dbpath              (conc work-area "/testdat.db"))
-	     (dbexists            (file-exists? dbpath))
+	     (dbexists            (common:file-exists? dbpath))
 	     (work-area-writeable (file-write-access? work-area))
 	     (db                  (handle-exceptions  ;; open the db if area writeable or db pre-existing. open in-mem otherwise. if exception, open in-mem
 				   exn
 				   (begin
 				     (print-call-chain (current-error-port))

DELETED testhttp/example-client.scm
Index: testhttp/example-client.scm
==================================================================
--- testhttp/example-client.scm
+++ /dev/null
@@ -1,6 +0,0 @@
-(use regex http-client)
-
-(print (with-input-from-request "http://localhost:8083/?foo=1" #f 
-    (lambda ()
-      (let ((match (string-search (regexp "(.*)<.body>") (caddr (string-split (read-string) "\n")))))
-	(cadr match)))))

DELETED testhttp/example-server.scm
Index: testhttp/example-server.scm
==================================================================
--- testhttp/example-server.scm
+++ /dev/null
@@ -1,26 +0,0 @@
-(use spiffy awful)
-
-(tcp-buffer-size 2048)
-(enable-sxml #t)
-
-(define (hello-world)
-  (define-page (main-page-path)
-    (lambda ()
-      (with-request-variables (foo)
-        foo))))
-
-(define (start-server #!key (portnum 8080))
-  (handle-exceptions
-   exn
-   (begin
-     (print-error-message exn)
-     (if (< portnum 9000)
-	 (begin 
-	   (print "WARNING: failed to start on portnum: " portnum ", trying next port")
-	   (sleep 1)
-	   (start-server portnum: (+ portnum 1)))
-	 (print "ERROR: Tried and tried but could not start the server")))
-   (print "INFO: Trying to start server on portnum: " portnum)
-   (awful-start hello-world port: portnum)))
-
-(start-server)

DELETED testhttp/mockupclient.scm
Index: testhttp/mockupclient.scm
==================================================================
--- testhttp/mockupclient.scm
+++ /dev/null
@@ -1,35 +0,0 @@
-(use posix)
-
-(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))
-
-(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 testhttp/mockupclientlib.scm
Index: testhttp/mockupclientlib.scm
==================================================================
--- testhttp/mockupclientlib.scm
+++ /dev/null
@@ -1,33 +0,0 @@
-(define sub  (make-socket 'sub))
-(define push (make-socket 'push))
-(socket-option-set! sub 'subscribe cname)
-(connect-socket sub "tcp://localhost:5563")
-(connect-socket push "tcp://localhost:5564")
-
-(define (dbaccess cname cmd var val #!key (numtries 1))
-  (let* ((msg (conc cname ":" cmd ":" (if val (conc var " " val) var)))
-	 (res #f)
-	 (do-access (lambda ()
-		      (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! res (receive-message* sub)))))
-    (let ((th1 (make-thread do-access "do access"))
-	  (th2 (make-thread (lambda ()
-			      (thread-sleep! 5)
-			      (if (not res)
-				  (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)
-      res)))
-

DELETED testhttp/mockupserver.scm
Index: testhttp/mockupserver.scm
==================================================================
--- testhttp/mockupserver.scm
+++ /dev/null
@@ -1,140 +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 srfi-18 sqlite3 spiffy)
-
-(define cname "server")
-(define total-db-accesses 0)
-(define start-time (current-seconds))
-
-;; setup the server here
-(tcp-buffer-size 2048)
-(server-port 5563)
-
-(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)))
-
-(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
-		     (count-client db cname)
-		     (case clcmd
-		       ((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")
-
-;; ;; 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"))
-
-(handle-not-found 
- 
-
-(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 testhttp/testclient.scm
Index: testhttp/testclient.scm
==================================================================
--- testhttp/testclient.scm
+++ /dev/null
@@ -1,8 +0,0 @@
-(use http-client)
-
-(with-input-from-request "http://localhost:12345/hey"
-                                           ;; #f
-                                           ;; msg 
-                                           (list (cons 'dat "Testing eh"))
-                                           read-string)
-

DELETED testhttp/testserver.scm
Index: testhttp/testserver.scm
==================================================================
--- testhttp/testserver.scm
+++ /dev/null
@@ -1,16 +0,0 @@
-(use spiffy uri-common intarweb spiffy-request-vars)
-
-(root-path "/var/www")
-
-(vhost-map `(((* any) . ,(lambda (continue)
-                           (let (($ (request-vars source: 'both)))
-			     (print ($ 'dat))
-			     (if (equal? (uri-path (request-uri (current-request))) 
-					 '(/ "hey"))
-				 (send-response body: "hey there!\n"
-						headers: '((content-type text/plain)))
-				 (continue)))))))
-
-(start-server port: 12345)
-
-

DELETED testnanomsg/basic-req-rep.scm
Index: testnanomsg/basic-req-rep.scm
==================================================================
--- testnanomsg/basic-req-rep.scm
+++ /dev/null
@@ -1,3 +0,0 @@
-(use nanomsg srfi-18 sqlite3 numbers)
-
-(define resp (nn-socket 'rep))

DELETED testnanomsg/mockupclient.scm
Index: testnanomsg/mockupclient.scm
==================================================================
--- testnanomsg/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 testnanomsg/mockupclientlib.scm
Index: testnanomsg/mockupclientlib.scm
==================================================================
--- testnanomsg/mockupclientlib.scm
+++ /dev/null
@@ -1,58 +0,0 @@
-(define reqs (nn-socket 'req))
-
-(connect-socket reqs "tcp://localhost:6563")
-
-(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 testnanomsg/mockupserver.scm
Index: testnanomsg/mockupserver.scm
==================================================================
--- testnanomsg/mockupserver.scm
+++ /dev/null
@@ -1,146 +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 nanomsg srfi-18 sqlite3 numbers)
-
-(define resp (nn-socket 'rep))
-(define cname "server")
-(define total-db-accesses 0)
-(define start-time (current-seconds))
-
-(nn-bind resp  "tcp://*:6563")
-
-(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 testnanomsg/pipeline.scm
Index: testnanomsg/pipeline.scm
==================================================================
--- testnanomsg/pipeline.scm
+++ /dev/null
@@ -1,25 +0,0 @@
-;; watch nanomsg's pipeline load-balancer in action.
-(use nanomsg)
-
-(define push (nn-socket 'push))
-(define pull1 (nn-socket 'pull))
-(define pull2 (nn-socket 'pull))
-
-(nn-bind    push  "inproc://test")
-(nn-connect pull1 "inproc://test")
-(nn-connect pull2 "inproc://test")
-
-(nn-send push "a")
-(nn-send push "b")
-(nn-send push "c")
-(nn-send push "d")
-
-(define ((th sock))
-  (print (current-thread) ": " (nn-recv sock))
-  (print (current-thread) ": " (nn-recv sock))
-  (print (current-thread) " is done"))
-
-(thread-start! (th pull1))
-(thread-start! (th pull2))
-
-(thread-sleep! 1)

DELETED testnanomsg/req-rep-client.scm
Index: testnanomsg/req-rep-client.scm
==================================================================
--- testnanomsg/req-rep-client.scm
+++ /dev/null
@@ -1,31 +0,0 @@
-;; watch nanomsg's pipeline load-balancer in action.
-(use nanomsg posix regex)
-
-(define req   (nn-socket 'req))
-
-(nn-connect req  "tcp://localhost:22022")
-
-;; (with-output-to-string (lambda ()(serialize obj)))
-(define (client-send-receive soc msg)
-  (nn-send soc msg)
-  (nn-recv soc))
-
-(define ((talk-to-server soc))
-  (let loop ((cnt 200000))
-    (let ((name (list-ref '("Matt" "Tom" "Bob" "Jill" "James" "Jane")(random 6))))
-      ;; (print "Sending " name)
-      ;; (print
-      (client-send-receive req name) ;; )
-      (if (> cnt 0)(loop (- cnt 1)))))
-  (print (client-send-receive req "quit"))
-  (nn-close req)
-  (exit))
-
-;; (thread-start! (lambda ()
-;; 		 (thread-sleep! 20)
-;; 		 (print "Give up on waiting for the server")
-;; 		 (nn-close req)
-;; 		 (exit)))
-
-(thread-join! (thread-start! (talk-to-server req)))
-

DELETED testnanomsg/req-rep-server.scm
Index: testnanomsg/req-rep-server.scm
==================================================================
--- testnanomsg/req-rep-server.scm
+++ /dev/null
@@ -1,94 +0,0 @@
-;; watch nanomsg's pipeline load-balancer in action.
-(use nanomsg posix regex)
-
-;; (use trace)
-;; (trace nn-bind nn-socket nn-assert nn-recv nn-send thread-terminate! nn-close )
-
-(define port  22022)
-(define host  "127.0.0.1")
-
-(define rep   (nn-socket 'rep))
-
-(print "connecting, got: " (nn-bind    rep  (conc "tcp://" "*" ":" port)))
-
-(define (server soc)
-  (print "server starting")
-  (let loop ((msg-in (nn-recv soc))
-	     (count  0))
-    (if (eq? 0 (modulo count 1000))
-	(print "server received: " msg-in ", count=" count))
-    (cond
-     ((equal? msg-in "quit")
-      (nn-send soc "Ok, quitting"))
-     ((and (>= (string-length msg-in) 4)
-	   (equal? (substring msg-in 0 4) "ping"))
-      (nn-send soc (conc (current-process-id)))
-      (loop (nn-recv soc)(+ count 1)))
-     ;;((and (>= (string-length msg-in)
-     (else
-      (let ((this-task  (/ (random 10) 200.0))
-	    (start-time (current-milliseconds)))
-	;; (thread-sleep! this-task)
-	(nn-send soc (conc "hello " msg-in " this task took " this-task " seconds to complete"))
-	;; (print "Actual send-receive time: " (- (current-milliseconds) start-time));
-	(loop (nn-recv soc)(+ count 1)))))))
-
-(define (ping-self host port #!key (return-socket #t))
-  ;; send a random number along with pid and check that we get it back
-  (let* ((req     (nn-socket 'req))
-	 (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")))
-    (nn-connect req (conc "tcp://" host ":" port))
-    (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 " host ":" port))
-     (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))))
-
-(let ((server-thread (make-thread (lambda ()(server rep)) "server")))
-  (thread-start! server-thread)
-  ;; (thread-sleep! 1)
-  (if (ping-self host port)
-      (begin
-	(thread-join! server-thread)
-	(nn-close rep))
-      (print "ping failed")))
-
-(exit)

DELETED testnanomsg/req-rep.scm
Index: testnanomsg/req-rep.scm
==================================================================
--- testnanomsg/req-rep.scm
+++ /dev/null
@@ -1,30 +0,0 @@
-;; watch nanomsg's pipeline load-balancer in action.
-(use nanomsg)
-
-(define req   (nn-socket 'req))
-(define rep   (nn-socket 'rep))
-
-(nn-bind    rep  "inproc://test")
-(nn-connect req  "inproc://test")
-
-(define (client-send-receive soc msg)
-  (nn-send soc msg)
-  (nn-recv soc))
-
-(define ((server soc))
-  (let loop ((msg-in (nn-recv soc)))
-    (if (not (equal? msg-in "quit"))
-	(begin
-	  (nn-send soc (conc "hello " msg-in))
-	  (loop (nn-recv soc))))))
-
-(thread-start! (server rep))
-
-(print (client-send-receive req "Matt"))
-(print (client-send-receive req "Tom"))
-
-;; (client-send-receive req "quit")
-
-(nn-close req)
-(nn-close rep)
-(exit)

DELETED testrpc/client.scm
Index: testrpc/client.scm
==================================================================
--- testrpc/client.scm
+++ /dev/null
@@ -1,8 +0,0 @@
-;;;; client.scm
-(use rpc posix)
-
-(define call (rpc:procedure 'foo "localhost"))
-
-(do ((i 10 (sub1 i)))
-    ((zero? i))
-  (print "-> " (call (random 100))))

DELETED testrpc/server.scm
Index: testrpc/server.scm
==================================================================
--- testrpc/server.scm
+++ /dev/null
@@ -1,15 +0,0 @@
-;;;; server.scm
-(use rpc)
-
-(rpc:publish-procedure!
- 'foo
- (lambda (x)
-   (print "foo: " x)
-   #f))
-
-(rpc:publish-procedure!
- 'fini
- (lambda () (print "fini") (thread-start! (lambda () (thread-sleep! 3) (print "terminate") (exit))) #f))
-
-((rpc:make-server (tcp-listen (rpc:default-server-port))) #t)
-

Index: tests.scm
==================================================================
--- tests.scm
+++ tests.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 .
+;;
 ;;======================================================================
 
 ;;======================================================================
 ;; Tests
 ;;======================================================================
@@ -31,10 +40,12 @@
 (include "common_records.scm")
 (include "key_records.scm")
 (include "db_records.scm")
 (include "run_records.scm")
 (include "test_records.scm")
+(include "js-path.scm")
+
 
 ;; Call this one to do all the work and get a standardized list of tests
 ;;   gets paths from configs and finds valid tests 
 ;;   returns hash of testname --> fullpath
 ;;
@@ -61,21 +72,28 @@
 (define (tests:get-valid-tests test-registry tests-paths)
   (if (null? tests-paths) 
       test-registry
       (let loop ((hed (car tests-paths))
 		 (tal (cdr tests-paths)))
-	(if (file-exists? hed)
+	(if (common:file-exists? hed)
 	    (for-each (lambda (test-path)
 			(let* ((tname   (last (string-split test-path "/")))
 			       (tconfig (conc test-path "/testconfig")))
 			  (if (and (not (hash-table-ref/default test-registry tname #f))
-				   (file-exists? tconfig))
+				   (common:file-exists? tconfig))
 			      (hash-table-set! test-registry tname test-path))))
 		      (glob (conc hed "/*"))))
 	(if (null? tal)
 	    test-registry
 	    (loop (car tal)(cdr tal))))))
+
+(define (tests:filter-test-names-not-matched test-names test-patts)
+  (delete-duplicates
+   (filter (lambda (testname)
+	     (not (tests:match test-patts testname #f)))
+	   test-names)))
+
 
 (define (tests:filter-test-names test-names test-patts)
   (delete-duplicates
    (filter (lambda (testname)
 	     (tests:match test-patts testname #f))
@@ -146,11 +164,11 @@
 
 
 ;; returns waitons waitors tconfigdat
 ;;
 (define (tests:get-waitons test-name all-tests-registry)
-   (let* ((config  (tests:get-testconfig test-name #f all-tests-registry 'return-procs)))
+   (let* ((config  (tests:get-testconfig test-name #f all-tests-registry 'return-procs))) ;; assuming no problems with immediate evaluation, this could be simplified ('return-procs -> #t)
      (let ((instr (if config 
 		      (config-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 \"" test-name "\"")
 			(exit 1))))
@@ -205,27 +223,54 @@
 ;;                                  mode itemwait
 ;;                                  # trim off the cell to determine what to run for genlib
 ;;                                  itemmap /.*
 ;;
 ;;                                  waiting-test is waiting on waiton-test so we need to create a pattern for waiton-test given waiting-test and itemmap
-(define (tests:extend-test-patts test-patt waiting-test waiton-test itemmaps)
-  (let* ((itemmap          (tests:lookup-itemmap itemmaps waiton-test))
-	 (patts            (string-split test-patt ","))
-	 (waiting-test-len (+ (string-length waiting-test) 1))
-	 (patts-waiton     (map (lambda (x)  ;; for each incoming patt that matches the waiting test
-				  (let* ((modpatt (if itemmap (db:convert-test-itempath x itemmap) x)) 
-					 (newpatt (conc waiton-test "/" (substring modpatt waiting-test-len (string-length modpatt)))))
-				    ;; (conc waiting-test "/," waiting-test "/" (substring modpatt waiton-test-len (string-length modpatt)))))
-				    ;; (print "in map, x=" x ", newpatt=" newpatt)
-				    newpatt))
-				(filter (lambda (x)
-					  (eq? (substring-index (conc waiting-test "/") x) 0)) ;; is this patt pertinent to the waiting test
-					patts))))
-    (string-intersperse (delete-duplicates (append patts (if (null? patts-waiton)
-							     (list (conc waiton-test "/%")) ;; really shouldn't add the waiton forcefully like this
-							     patts-waiton)))
-			",")))
+;; BB> (tests:extend-test-patts "normal-second/2" "normal-second" "normal-first" '())
+;; observed -> "normal-first/2,normal-first/,normal-second/2,normal-second/"
+;; expected -> "normal-first,normal-second/2,normal-second/"
+;; testpatt = normal-second/2
+;; waiting-test = normal-second
+;; waiton-test = normal-first
+;; itemmaps = ()
+
+(define (tests:extend-test-patts test-patt waiting-test waiton-test itemmaps itemized-waiton)
+  (cond
+   (itemized-waiton
+    (let* ((itemmap          (tests:lookup-itemmap itemmaps waiton-test))
+           (patts            (string-split test-patt ","))
+           (waiting-test-len (+ (string-length waiting-test) 1))
+           (patts-waiton     (map (lambda (x)  ;; for each incoming patt that matches the waiting test
+                                    (let* ((modpatt (if itemmap (db:convert-test-itempath x itemmap) x)) 
+                                           (newpatt (conc waiton-test "/" (substring modpatt waiting-test-len (string-length modpatt)))))
+                                      ;; (conc waiting-test "/," waiting-test "/" (substring modpatt waiton-test-len (string-length modpatt)))))
+                                      ;; (print "in map, x=" x ", newpatt=" newpatt)
+                                      newpatt))
+                                  (filter (lambda (x)
+                                            (eq? (substring-index (conc waiting-test "/") x) 0)) ;; is this patt pertinent to the waiting test
+                                          patts)))
+           (extended-test-patt   (append patts (if (null? patts-waiton)
+                                                   (list (conc waiton-test "/%")) ;; really shouldn't add the waiton forcefully like this
+                                                   patts-waiton)))
+           (extended-test-patt-with-toplevels
+            (fold (lambda (testpatt-item accum )
+                    (let ((my-match (string-match "^([^%\\/]+)\\/.+$" testpatt-item)))
+                      (cons testpatt-item
+                            (if my-match
+                                (cons
+                                 (conc (cadr my-match) "/")
+                                 accum)
+                                accum))))
+                  '()
+                  extended-test-patt)))
+      (string-intersperse (delete-duplicates extended-test-patt-with-toplevels) ",")))
+   (else ;; not waiting on items, waiting on entire waiton test.
+    (let* ((patts (string-split test-patt ","))
+           (new-patts (if (member waiton-test patts)
+                          patts
+                          (cons waiton-test patts))))
+      (string-intersperse (delete-duplicates new-patts) ",")))))
 
 
   
 ;; tests:glob-like-match 
 (define (tests:glob-like-match patt str) 
@@ -305,11 +350,11 @@
 	  (db:test-get-rundir prev-testdat)) ;; )
 	 (waivers     (if testconfig (configf:section-vars testconfig "waivers") '()))
 	 (waiver-rx   (regexp "^(\\S+)\\s+(.*)$"))
 	 (diff-rule   "diff %file1% %file2%")
 	 (logpro-rule "diff %file1% %file2% | logpro %waivername%.logpro %waivername%.html"))
-    (if (not (file-exists? test-rundir))
+    (if (not (common:file-exists? test-rundir))
 	(begin
 	  (debug:print-error 0 *default-log-port* "test run directory is gone, cannot propagate waiver")
 	  #f)
 	(begin
 	  (push-directory test-rundir)
@@ -322,11 +367,11 @@
 				     (wparts      (if waiver (string-match waiver-rx waiver) #f))
 				     (waiver-rule (if wparts (cadr wparts)  #f))
 				     (waiver-glob (if wparts (caddr wparts) #f))
 				     (logpro-file (if waiver
 						      (let ((fname (conc hed ".logpro")))
-							(if (file-exists? fname)
+							(if (common:file-exists? fname)
 							    fname 
 							    (begin
 							      (debug:print 0 *default-log-port* "INFO: No logpro file " fname " falling back to diff")
 							      #f)))
 						      #f))
@@ -420,19 +465,19 @@
     ;;       (sqlite3:execute db "UPDATE tests SET first_warn=? WHERE run_id=? AND testname=? AND item_path=?;" val run-id test-name item-path)))
 
     (let ((category (hash-table-ref/default otherdat ":category" ""))
 	  (variable (hash-table-ref/default otherdat ":variable" ""))
 	  (value    (hash-table-ref/default otherdat ":value"    #f))
-	  (expected (hash-table-ref/default otherdat ":expected" #f))
-	  (tol      (hash-table-ref/default otherdat ":tol"      #f))
+	  (expected (hash-table-ref/default otherdat ":expected" "n/a"))
+	  (tol      (hash-table-ref/default otherdat ":tol"      "n/a"))
 	  (units    (hash-table-ref/default otherdat ":units"    ""))
 	  (type     (hash-table-ref/default otherdat ":type"     ""))
 	  (dcomment (hash-table-ref/default otherdat ":comment"  "")))
       (debug:print 4 *default-log-port* 
 		   "category: " category ", variable: " variable ", value: " value
 		   ", expected: " expected ", tol: " tol ", units: " units)
-      (if (and value expected tol) ;; all three required
+      (if (and value) ;; require only value; BB was- all three required
 	  (let ((dat (conc category ","
 			   variable ","
 			   value    ","
 			   expected ","
 			   tol      ","
@@ -439,11 +484,13 @@
 			   units    ","
 			   dcomment ",," ;; extra comma for status
 			   type     )))
 	    ;; This was run remote, don't think that makes sense. Perhaps not, but that is the easiest path for the moment.
 	    (rmt:csv->test-data run-id test-id
-				dat))))
+				dat)
+            (thread-sleep! 10) ;; add 10 second delay before quit incase rmt needs time to start a server.
+            )))
       
     ;; need to update the top test record if PASS or FAIL and this is a subtest
     ;;;;;; (if (not (equal? item-path ""))
     ;;;;;;     (rmt:set-state-status-and-roll-up-items run-id test-name item-path state status #f) ;;;;;)
 
@@ -581,13 +628,18 @@
 .HandCursorStyle { cursor: pointer; cursor: hand; }  /* For IE */
 th {background-color: #8c8c8c;}
 td.test {background-color: #d9dbdd;}
 td.PASS {background-color: #347533;}
 td.FAIL {background-color: #cc2812;}
+td.SKIP{background-color: #FFD733;}
+td.WARN {background-color: #EA8724;}
+td.WAIVED {background-color: #838A12;}
+td.ABORT{background-color: #EA24B7;}
+.PASS .link, .SKIP .link, .WARN .link,.WAIVED .link,.ABORT .link, .FAIL .link{color: #FFFFFF;}
 
-  
-  
+
+
 
 
   
 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)))))
 
 
@@ -709,57 +779,35 @@
                (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:create-html-tree "test-index.html")
+;; tests:genrate dashboard body 
 ;;
-(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))
-         (total-runs  (rmt:get-num-runs "%"))
-         (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"))))
-               (start (* page pg-size)) 
-	       (runsdat   (rmt:get-runs "%" pg-size start (map (lambda (x)(list x "%")) keys)))
+
+(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))
+                    ; 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))
-               (get-prev-links (lambda (page linktree )   
-                            (let* ((link  (if (not (eq? page 0))
-                                            (s:a "<<prev" 'href (conc  linktree "/page" (- page 1) ".html"))
-                                            (s:a "" 'href (conc  linktree "/page"  page ".html")))))
-                               link)))
-                (get-next-links (lambda (page linktree total-runs)   
-                            (let* ((link  (if (> total-runs (+ 1 (* page pg-size)))
-                                            (s:a "next>>" 'href (conc  linktree "/page"  (+ page 1) ".html"))
-                                             (s:a "" 'href (conc  linktree "/page" page  ".html")))))
-                               link))))
-	  (s:output-new
-	   oup
-	   (s:html tests:css-jscript-block
+         (ctr 0)
+         (test-runs-hash (tests:get-rest-data runs header numkeys))
+         (test-list (hash-table-keys test-runs-hash))) 
+  (print header )
+  (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"
+			   (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)))
@@ -768,11 +816,11 @@
                                res))
                                keys)
                                (s:tr
 				 (s:th "Run Name")
                                   (map (lambda (run)
-                                   (s:th  (vector-ref run 3)))
+                                   (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<=?))) 
@@ -782,32 +830,339 @@
                                                            (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"))
                                                                       (status (if (string? result)
-                                                                                 (begin 
-                                                                                  ; (print "string" result)
-                                                                                     result)
-                                                                                 (begin 
-                                                                                   ;  (print "not string" result )
-                                                                                 (car result)))))
-                                                                       (s:td  status 'class status)))
+										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 (cadr result))))))
+                                                                       (s:td  link 'class status)))
                                                                 runs))))
                                                         res))
                                                    item-keys)))
-                               test-list)))))
+                               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 (if (args:get-arg "-run-patt")
+                        (args:get-arg "-run-patt")
+                        "%"))
+         (target (if (args:get-arg "-target-patt")
+                        (args:get-arg "-target-patt")
+                        "%"))
+         (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  linktree "/page" (- page 1) ".html"))
+                                   (s:a "" 'href (conc  linktree "/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  linktree "/page"  (+ page 1) ".html"))
+                                   (s:a "" 'href (conc  linktree "/page" page  ".html")))))
+                               link))) )
+          (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))
 	            
 	#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 (if (args:get-arg "-run-patt")
+                        (args:get-arg "-run-patt")
+                        "%"))
+        (target (if (args:get-arg "-target-patt")
+                        (args:get-arg "-target-patt")
+                        "%"))
+         (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 
+														(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 linktree "/" 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 '()))
@@ -839,11 +1194,11 @@
 						      '()
 						      (lambda (x p)
 							(let* ((targ-path (string-intersperse p "/"))
                                                                (full-path (conc linktree "/" targ-path))
                                                                (run-name  (car (reverse p))))
-                                                          (if (and (file-exists? full-path)
+                                                          (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")
@@ -878,11 +1233,11 @@
                                            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 (file-exists? html-dir)
+                    (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)
@@ -906,21 +1261,21 @@
                                                                           (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 (file-exists? alt-file)
+                                                                          (html-file (if (common:file-exists? alt-file)
                                                                                          alt-file
                                                                                          std-file))
                                                                           (run-name  (car (reverse p))))
-                                                                     (if (and (not (file-exists? full-targ))
+                                                                     (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 (file-exists? full-targ)
+                                                                     (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)))))
                                                                  ))))))
@@ -1075,11 +1430,11 @@
 			    (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
+	     (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"))
@@ -1129,11 +1484,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 "/")))
@@ -1146,28 +1501,29 @@
 	   (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 item-path test-registry system-allowed #!key (force-create #f))
+(define (tests:get-testconfig test-name item-path test-registry system-allowed #!key (force-create #f)(allow-write-cache #t))
   (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
 				use-cache)
 			   (handle-exceptions
 			    exn
@@ -1187,11 +1543,11 @@
 	      (let* ((treg         (or test-registry
 				       (tests:get-all)))
 		     (test-path    (or (hash-table-ref/default treg test-name #f)
 				       (conc *toppath* "/tests/" test-name)))
 		     (test-configf (conc test-path "/testconfig"))
-		     (testexists   (and (file-exists? test-configf)(file-read-access? test-configf)))
+		     (testexists   (and (common:file-exists? test-configf)(file-read-access? test-configf)))
 		     (tcfg         (if testexists
 				       (read-config test-configf #f system-allowed
 						    environ-patt: (if system-allowed
 								      "pre-launch-env-vars"
 								      #f))
@@ -1198,11 +1554,12 @@
 				       #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-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)
                       (if (not (common:in-running-test?))
                           (configf:write-alist tcfg tpath))))
 		tcfg))))))
@@ -1356,11 +1713,11 @@
 ;;
 (define (tests:lazy-dot testrecords  outtype sizex sizey)
   (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)
+    (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)
@@ -1559,11 +1916,11 @@
 	   (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 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))))
      (tests:update-testdat-meta-info db test-id work-area cpuload diskfree minutes)
   )))
 	 

Index: tests/Makefile
==================================================================
--- tests/Makefile
+++ tests/Makefile
@@ -173,11 +173,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/fdktestqa/fdk.config
==================================================================
--- tests/fdktestqa/fdk.config
+++ tests/fdktestqa/fdk.config
@@ -3,34 +3,26 @@
 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
@@ -3,22 +3,23 @@
 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) -run -testpatt % -target a/b -runname c
 
 bigbig :
 	for tn in a b c d;do \
-	   ($(MEGATEST) -run -testpatt % -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

Index: tests/fdktestqa/testqa/megatest.config
==================================================================
--- tests/fdktestqa/testqa/megatest.config
+++ tests/fdktestqa/testqa/megatest.config
@@ -1,12 +1,18 @@
 [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
+# 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 

Index: tests/fdktestqa/testqa/runconfigs.config
==================================================================
--- tests/fdktestqa/testqa/runconfigs.config
+++ tests/fdktestqa/testqa/runconfigs.config
@@ -1,5 +1,7 @@
+[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/tests/bigrun2/testconfig
==================================================================
--- tests/fdktestqa/testqa/tests/bigrun2/testconfig
+++ tests/fdktestqa/testqa/tests/bigrun2/testconfig
@@ -9,11 +9,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/fullrun/megatest.config
==================================================================
--- tests/fullrun/megatest.config
+++ tests/fullrun/megatest.config
@@ -47,11 +47,13 @@
 waivercommentpatt ^WW\d+ [a-z].*
 incomplete-timeout 1
 
 # wait 0.5 seconds between launching every process
 #
-launch-delay 0.5
+# launch-delay 0.5
+launch-delay 0
+
 
 # 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
@@ -252,10 +254,12 @@
 
 # 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
+maxload 1.1
+maxhomehostload 1.1
 
 [configf:settings trim-trailing-spaces yes]
 
 # Override the rollup for specific tests
 [testrollup]

Index: tests/fullrun/runconfigs.config
==================================================================
--- tests/fullrun/runconfigs.config
+++ tests/fullrun/runconfigs.config
@@ -1,10 +1,10 @@
 [default]
 SOMEVAR This should show up in SOMEVAR3
 VARNOVAL
 VARNOVAL_WITHSPACE
-QUICK %
+QUICKPATT test_mt_vars,test2,priority_9
 
 # 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]

ADDED   tests/fullrun/test-teamcity-run.sh
Index: tests/fullrun/test-teamcity-run.sh
==================================================================
--- /dev/null
+++ tests/fullrun/test-teamcity-run.sh
@@ -0,0 +1,5 @@
+#!/bin/bash
+
+(cd ../..;make install) && RN=tcmt_m;megatest -remove-runs -target ubuntu/nfs/none -runname tcmt_m -testpatt %;\
+    tcmt -run -target ubuntu/nfs/none -runname tcmt_m -testpatt % -rerun-clean 2>&1 | tee all.log | grep teamcity | tee teamcity.log
+

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)

Index: tests/unittests/all-rmt.scm
==================================================================
--- tests/unittests/all-rmt.scm
+++ tests/unittests/all-rmt.scm
@@ -28,13 +28,25 @@
 ;; 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" (hash-table->alist (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))
@@ -82,11 +94,27 @@
 (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))))))
+
 ;; (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))

Index: tests/unittests/tests.scm
==================================================================
--- tests/unittests/tests.scm
+++ tests/unittests/tests.scm
@@ -12,67 +12,70 @@
 ;; 	 (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)

Index: tests/vectors-vs-records.scm
==================================================================
--- tests/vectors-vs-records.scm
+++ tests/vectors-vs-records.scm
@@ -1,5 +1,20 @@
+;; 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

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,36 @@
+(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:))
@@ -22,11 +31,11 @@
 (declare (uses launch))
 (declare (uses megatest-version))
 (declare (uses gutils))
 (declare (uses db))
 (declare (uses server))
-(declare (uses synchash))
+;; (declare (uses synchash))
 (declare (uses dcommon))
 
 (include "common_records.scm")
 (include "db_records.scm")
 (include "key_records.scm")
@@ -69,11 +78,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

Index: txtdb/metadat.scm
==================================================================
--- txtdb/metadat.scm
+++ txtdb/metadat.scm
@@ -1,5 +1,20 @@
+;; 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 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"))

Index: utils/Makefile.git.installall
==================================================================
--- utils/Makefile.git.installall
+++ utils/Makefile.git.installall
@@ -47,11 +47,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 +174,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

Index: utils/Makefile.installall
==================================================================
--- utils/Makefile.installall
+++ utils/Makefile.installall
@@ -45,11 +45,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 +56,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 +97,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 +137,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 +150,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
@@ -235,11 +227,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 +247,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 +273,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 +337,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)

ADDED   utils/checkPreReqs
Index: utils/checkPreReqs
==================================================================
--- /dev/null
+++ utils/checkPreReqs
@@ -0,0 +1,30 @@
+#!/bin/bash
+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

ADDED   utils/cleanup-pkts.sh
Index: utils/cleanup-pkts.sh
==================================================================
--- /dev/null
+++ utils/cleanup-pkts.sh
@@ -0,0 +1,12 @@
+#!/bin/bash
+
+pushd $1
+
+for x in *.pkt;do
+    if grep 'T configf' $x > /dev/null;then
+        rm $x
+    else
+        echo skip $x
+    fi
+done
+

ADDED   utils/editwiki
Index: utils/editwiki
==================================================================
--- /dev/null
+++ utils/editwiki
@@ -0,0 +1,56 @@
+#!/bin/bash
+
+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,20 @@
+;; 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

Index: utils/fslrept.scm
==================================================================
--- utils/fslrept.scm
+++ utils/fslrept.scm
@@ -1,5 +1,20 @@
+;; 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
 ;;

Index: utils/installall.sh
==================================================================
--- utils/installall.sh
+++ utils/installall.sh
@@ -12,20 +12,28 @@
 # 
 #  This program is distributed WITHOUT ANY WARRANTY; without even the
 #  implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
 #  PURPOSE.
 
-if [[ $OPTION=="" ]]; then
+# 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 libpangox-1.0-0 zlib1g-dev libfreetype6-dev cmake
-echo sudo apt-get install libssl-dev  uuid-dev
-echo sudo apt-get install libmotif3 -OR- set KTYPE=26g4
+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
@@ -35,48 +43,79 @@
 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.11.0
-CHICKEN_BASEVER=4.11.0
+
+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.10
-	IUPVER=3.17
-	IMVER=3.11
-	CHICKEN_VERSION=4.12.0
-	CHICKEN_BASEVER=4.12.0
+	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.10
-	IUPVER=3.17
-	IMVER=3.11
+	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.10
-	IUPVER=3.17
-	IMVER=3.11
+	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:
 #
 # NB// fix the paths first
@@ -101,10 +140,11 @@
 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'
@@ -153,22 +193,25 @@
     make PLATFORM=linux PREFIX=$PREFIX
     make PLATFORM=linux PREFIX=$PREFIX install
     cd $BUILDHOME
 fi
 cd $BUILDHOME
-#wget --no-check-certificate https://github.com/nanomsg/nanomsg/archive/1.0.0.tar.gz 
-#mv 1.0.0 1.0.0.tar.gz
-# if ! [[ -e $PREFIX/lib64/libnanomsg.so.1.0.0 ]]; 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
-# 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
@@ -182,15 +225,28 @@
 		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
+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
@@ -202,22 +258,24 @@
 # 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
 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 spiffy uri-common intarweb http-client \
+	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 logpro z3 call-with-environment-variables \
-	pathname-expand typed-records simple-exceptions numbers crypt parley srfi-42 \
+	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
+	udp uuid uuid-lib zlib postgresql
 
 do
 	echo "Installing $egg"
 	$CHICKEN_INSTALL $PROX -keep-installed $egg
 	#$CHICKEN_INSTALL $PROX $egg
@@ -225,38 +283,23 @@
 		echo "$egg failed to install"
 		exit 1
 	fi
 done
 
-if [[ -e `which mysql_config` ]]; then
-  $CHICKEN_INSTALL $PROX -keep-installed mysql-client
+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
-# # IUP versions
-# if [[ x$USEOLDIUP == "x" ]];then
-#   CDVER=5.10
-#   IUPVER=3.17
-#   IMVER=3.11
-# else
-#   CDVER=5.10
-#   IUPVER=3.17
-#   IMVER=3.11
-# fi
-# if [[ x$KTYPE == "x24g3" ]];then
-#   CDVER=5.4.1
-#   IUPVER=3.5
-#   IMVER=3.6.3
-# fi
 
 if [[ `uname -a | grep x86_64` == "" ]]; then 
     export ARCHSIZE=''
 else
     export ARCHSIZE=64_
@@ -270,21 +313,25 @@
 fi
 echo $files
 
 mkdir -p $PREFIX/iuplib
 mkdir -p iup/
-for a in `echo $files` ; do
+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 `echo $a | cut -d'/' -f2` tgz/
+	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/$a into $BUILDHOME/lib
-    tar -xzf tgz/`echo $a | cut -d'/' -f2` -C iup/
-    #(cd $PREFIX/lib;tar xfvz $BUILDHOME/tgz/$a;mv include/* ../include)
-    # (cd $DEPLOYTARG;tar xfvz $BUILDHOME/$a)
+    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
@@ -319,14 +366,16 @@
 	$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
+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
@@ -346,22 +395,26 @@
 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 $IUPEGGVER
+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
-cd ../ducttape
-$CHICKEN_INSTALL
+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
 

ADDED   utils/memproblem.scm
Index: utils/memproblem.scm
==================================================================
--- /dev/null
+++ utils/memproblem.scm
@@ -0,0 +1,63 @@
+;; 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,13 +1,13 @@
 #!/bin/bash
 
 prefix=$1
 cmd=$2
 target=$3
+cfgfile="$prefix/bin/.$(lsb_release -sr)/cfg.sh"
 
 if [ "$LD_LIBRARY_PATH" != "" ];then
-  cfgfile="$prefix/bin/.$(lsb_release -sr)/cfg.sh"
   echo "INFO: Using LD_LIBRARY_PATH=$LD_LIBRARY_PATH" >&2
 ( cat << __EOF
 if [ "\$LD_LIBRARY_PATH" != "" ];then
   export LD_LIBRARY_PATH=$LD_LIBRARY_PATH:\$LD_LIBRARY_PATH
 else
@@ -18,15 +18,10 @@
   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'
 
@@ -57,8 +52,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/mtrept.sh
Index: utils/mtrept.sh
==================================================================
--- /dev/null
+++ utils/mtrept.sh
@@ -0,0 +1,58 @@
+#!/bin/bash
+#
+# 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/plot-code.scm
==================================================================
--- utils/plot-code.scm
+++ utils/plot-code.scm
@@ -1,6 +1,22 @@
 #!/mfs/pkgs/chicken/4.8.0.5/bin/csi -nbq
+
+;; 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

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,184 @@
+#!/p/foundry/env/pkgs/chicken/4.10.1_v1.63/bin/csi -s
+; -*- Mode: Scheme; -*-
+
+;; 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)
+  
+  
+  )

ADDED   utils/watch-close-wait.sh
Index: utils/watch-close-wait.sh
==================================================================
--- /dev/null
+++ utils/watch-close-wait.sh
@@ -0,0 +1,8 @@
+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,63 @@
+;; 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 posix srfi-69)
+
+(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)list
+  (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)))))
+
+(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 and normalize the 
+(for-each
+ (lambda (indat)
+   (let ((pid (car indat))
+         (usr (cadr indat))
+         (cpu (list-ref indat 8)))
+     (hash-table-set! userhash usr (+ cpu (hash-table-ref/default userhash usr 0)))))
+ data)
+
+(for-each
+ (lambda (usr)
+   (print usr
+          (if (< (string-length usr) 8) "\t\t" "\t")
+          (inexact->exact (round (/ (hash-table-ref userhash usr) *numsamples*)))))
+ (sort (hash-table-keys userhash)
+       (lambda (a b)
+         (> (hash-table-ref userhash a)
+            (hash-table-ref userhash b)))))
+

Index: vg-test.scm
==================================================================
--- vg-test.scm
+++ vg-test.scm
@@ -1,5 +1,20 @@
+;; 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_records.scm
==================================================================
--- vg_records.scm
+++ vg_records.scm
@@ -1,7 +1,23 @@
 ;; Created by records.sh. DO NOT EDIT THIS FILE. Edit records.sh instead
 ;; Generated using make-vector-record -safe vg lib comps
+
+;; 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 

ADDED   wrappers/cfg.sh
Index: wrappers/cfg.sh
==================================================================
--- /dev/null
+++ wrappers/cfg.sh
@@ -0,0 +1,6 @@
+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,32 @@
+#!/bin/bash
+
+# # 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,6 @@
+#!/bin/bash
+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/mtest "$@"
+