') + .hide() + .insertBefore( $(obj) ) + .bind('fancybox-cleanup', function() { + $(this).replaceWith(content.children()); + }).bind('fancybox-cancel', function() { + $(this).replaceWith(tmp.children()); + }); + + $(obj).appendTo(tmp); + + _process_inline(); + break; + + case 'image': + busy = false; + + $.fancybox.showActivity(); + + imgPreloader = new Image(); + + imgPreloader.onerror = function() { + _error(); + }; + + imgPreloader.onload = function() { + busy = true; + + imgPreloader.onerror = imgPreloader.onload = null; + + _process_image(); + }; + + imgPreloader.src = href; + break; + + case 'swf': + selectedOpts.scrolling = 'no'; + + str = '

'; + + tmp.html(str); + + _process_inline(); + break; + + case 'ajax': + busy = false; + + $.fancybox.showActivity(); + + selectedOpts.ajax.win = selectedOpts.ajax.success; + + ajaxLoader = $.ajax($.extend({}, selectedOpts.ajax, { + url : href, + data : selectedOpts.ajax.data || {}, + error : function(XMLHttpRequest, textStatus, errorThrown) { + if ( XMLHttpRequest.status > 0 ) { + _error(); + } + }, + success : function(data, textStatus, XMLHttpRequest) { + var o = typeof XMLHttpRequest == 'object' ? XMLHttpRequest : ajaxLoader; + if (o.status == 200) { + if ( typeof selectedOpts.ajax.win == 'function' ) { + ret = selectedOpts.ajax.win(href, data, textStatus, XMLHttpRequest); + + if (ret === false) { + loading.hide(); + return; + } else if (typeof ret == 'string' || typeof ret == 'object') { + data = ret; + } + } + + tmp.html( data ); + _process_inline(); + } + } + })); + + break; + + case 'iframe': + _show(); + break; + } + }, + + _process_inline = function() { + var + w = selectedOpts.width, + h = selectedOpts.height; + + if (w.toString().indexOf('%') > -1) { + w = parseInt( ($(window).width() - (selectedOpts.margin * 2)) * parseFloat(w) / 100, 10) + 'px'; + + } else { + w = w == 'auto' ? 'auto' : w + 'px'; + } + + if (h.toString().indexOf('%') > -1) { + h = parseInt( ($(window).height() - (selectedOpts.margin * 2)) * parseFloat(h) / 100, 10) + 'px'; + + } else { + h = h == 'auto' ? 'auto' : h + 'px'; + } + + tmp.wrapInner('

'); + + selectedOpts.width = tmp.width(); + selectedOpts.height = tmp.height(); + + _show(); + }, + + _process_image = function() { + selectedOpts.width = imgPreloader.width; + selectedOpts.height = imgPreloader.height; + + $("").attr({ + 'id' : 'fancybox-img', + 'src' : imgPreloader.src, + 'alt' : selectedOpts.title + }).appendTo( tmp ); + + _show(); + }, + + _show = function() { + var pos, equal; + + loading.hide(); + + if (wrap.is(":visible") && false === currentOpts.onCleanup(currentArray, currentIndex, currentOpts)) { + $.event.trigger('fancybox-cancel'); + + busy = false; + return; + } + + busy = true; + + $(content.add( overlay )).unbind(); + + $(window).unbind("resize.fb scroll.fb"); + $(document).unbind('keydown.fb'); + + if (wrap.is(":visible") && currentOpts.titlePosition !== 'outside') { + wrap.css('height', wrap.height()); + } + + currentArray = selectedArray; + currentIndex = selectedIndex; + currentOpts = selectedOpts; + + if (currentOpts.overlayShow) { + overlay.css({ + 'background-color' : currentOpts.overlayColor, + 'opacity' : currentOpts.overlayOpacity, + 'cursor' : currentOpts.hideOnOverlayClick ? 'pointer' : 'auto', + 'height' : $(document).height() + }); + + if (!overlay.is(':visible')) { + if (isIE6) { + $('select:not(#fancybox-tmp select)').filter(function() { + return this.style.visibility !== 'hidden'; + }).css({'visibility' : 'hidden'}).one('fancybox-cleanup', function() { + this.style.visibility = 'inherit'; + }); + } + + overlay.show(); + } + } else { + overlay.hide(); + } + + final_pos = _get_zoom_to(); + + _process_title(); + + if (wrap.is(":visible")) { + $( close.add( nav_left ).add( nav_right ) ).hide(); + + pos = wrap.position(), + + start_pos = { + top : pos.top, + left : pos.left, + width : wrap.width(), + height : wrap.height() + }; + + equal = (start_pos.width == final_pos.width && start_pos.height == final_pos.height); + + content.fadeTo(currentOpts.changeFade, 0.3, function() { + var finish_resizing = function() { + content.html( tmp.contents() ).fadeTo(currentOpts.changeFade, 1, _finish); + }; + + $.event.trigger('fancybox-change'); + + content + .empty() + .removeAttr('filter') + .css({ + 'border-width' : currentOpts.padding, + 'width' : final_pos.width - currentOpts.padding * 2, + 'height' : selectedOpts.autoDimensions ? 'auto' : final_pos.height - titleHeight - currentOpts.padding * 2 + }); + + if (equal) { + finish_resizing(); + + } else { + fx.prop = 0; + + $(fx).animate({prop: 1}, { + duration : currentOpts.changeSpeed, + easing : currentOpts.easingChange, + step : _draw, + complete : finish_resizing + }); + } + }); + + return; + } + + wrap.removeAttr("style"); + + content.css('border-width', currentOpts.padding); + + if (currentOpts.transitionIn == 'elastic') { + start_pos = _get_zoom_from(); + + content.html( tmp.contents() ); + + wrap.show(); + + if (currentOpts.opacity) { + final_pos.opacity = 0; + } + + fx.prop = 0; + + $(fx).animate({prop: 1}, { + duration : currentOpts.speedIn, + easing : currentOpts.easingIn, + step : _draw, + complete : _finish + }); + + return; + } + + if (currentOpts.titlePosition == 'inside' && titleHeight > 0) { + title.show(); + } + + content + .css({ + 'width' : final_pos.width - currentOpts.padding * 2, + 'height' : selectedOpts.autoDimensions ? 'auto' : final_pos.height - titleHeight - currentOpts.padding * 2 + }) + .html( tmp.contents() ); + + wrap + .css(final_pos) + .fadeIn( currentOpts.transitionIn == 'none' ? 0 : currentOpts.speedIn, _finish ); + }, + + _format_title = function(title) { + if (title && title.length) { + if (currentOpts.titlePosition == 'float') { + return '

' + title + '

'; + } + + return '

' + title + '

'; + } + + return false; + }, + + _process_title = function() { + titleStr = currentOpts.title || ''; + titleHeight = 0; + + title + .empty() + .removeAttr('style') + .removeClass(); + + if (currentOpts.titleShow === false) { + title.hide(); + return; + } + + titleStr = $.isFunction(currentOpts.titleFormat) ? currentOpts.titleFormat(titleStr, currentArray, currentIndex, currentOpts) : _format_title(titleStr); + + if (!titleStr || titleStr === '') { + title.hide(); + return; + } + + title + .addClass('fancybox-title-' + currentOpts.titlePosition) + .html( titleStr ) + .appendTo( 'body' ) + .show(); + + switch (currentOpts.titlePosition) { + case 'inside': + title + .css({ + 'width' : final_pos.width - (currentOpts.padding * 2), + 'marginLeft' : currentOpts.padding, + 'marginRight' : currentOpts.padding + }); + + titleHeight = title.outerHeight(true); + + title.appendTo( outer ); + + final_pos.height += titleHeight; + break; + + case 'over': + title + .css({ + 'marginLeft' : currentOpts.padding, + 'width' : final_pos.width - (currentOpts.padding * 2), + 'bottom' : currentOpts.padding + }) + .appendTo( outer ); + break; + + case 'float': + title + .css('left', parseInt((title.width() - final_pos.width - 40)/ 2, 10) * -1) + .appendTo( wrap ); + break; + + default: + title + .css({ + 'width' : final_pos.width - (currentOpts.padding * 2), + 'paddingLeft' : currentOpts.padding, + 'paddingRight' : currentOpts.padding + }) + .appendTo( wrap ); + break; + } + + title.hide(); + }, + + _set_navigation = function() { + if (currentOpts.enableEscapeButton || currentOpts.enableKeyboardNav) { + $(document).bind('keydown.fb', function(e) { + if (e.keyCode == 27 && currentOpts.enableEscapeButton) { + e.preventDefault(); + $.fancybox.close(); + + } else if ((e.keyCode == 37 || e.keyCode == 39) && currentOpts.enableKeyboardNav && e.target.tagName !== 'INPUT' && e.target.tagName !== 'TEXTAREA' && e.target.tagName !== 'SELECT') { + e.preventDefault(); + $.fancybox[ e.keyCode == 37 ? 'prev' : 'next'](); + } + }); + } + + if (!currentOpts.showNavArrows) { + nav_left.hide(); + nav_right.hide(); + return; + } + + if ((currentOpts.cyclic && currentArray.length > 1) || currentIndex !== 0) { + nav_left.show(); + } + + if ((currentOpts.cyclic && currentArray.length > 1) || currentIndex != (currentArray.length -1)) { + nav_right.show(); + } + }, + + _finish = function () { + if (!$.support.opacity) { + content.get(0).style.removeAttribute('filter'); + wrap.get(0).style.removeAttribute('filter'); + } + + if (selectedOpts.autoDimensions) { + content.css('height', 'auto'); + } + + wrap.css('height', 'auto'); + + if (titleStr && titleStr.length) { + title.show(); + } + + if (currentOpts.showCloseButton) { + close.show(); + } + + _set_navigation(); + + if (currentOpts.hideOnContentClick) { + content.bind('click', $.fancybox.close); + } + + if (currentOpts.hideOnOverlayClick) { + overlay.bind('click', $.fancybox.close); + } + + $(window).bind("resize.fb", $.fancybox.resize); + + if (currentOpts.centerOnScroll) { + $(window).bind("scroll.fb", $.fancybox.center); + } + + if (currentOpts.type == 'iframe') { + $('').appendTo(content); + } + + wrap.show(); + + busy = false; + + $.fancybox.center(); + + currentOpts.onComplete(currentArray, currentIndex, currentOpts); + + _preload_images(); + }, + + _preload_images = function() { + var href, + objNext; + + if ((currentArray.length -1) > currentIndex) { + href = currentArray[ currentIndex + 1 ].href; + + if (typeof href !== 'undefined' && href.match(imgRegExp)) { + objNext = new Image(); + objNext.src = href; + } + } + + if (currentIndex > 0) { + href = currentArray[ currentIndex - 1 ].href; + + if (typeof href !== 'undefined' && href.match(imgRegExp)) { + objNext = new Image(); + objNext.src = href; + } + } + }, + + _draw = function(pos) { + var dim = { + width : parseInt(start_pos.width + (final_pos.width - start_pos.width) * pos, 10), + height : parseInt(start_pos.height + (final_pos.height - start_pos.height) * pos, 10), + + top : parseInt(start_pos.top + (final_pos.top - start_pos.top) * pos, 10), + left : parseInt(start_pos.left + (final_pos.left - start_pos.left) * pos, 10) + }; + + if (typeof final_pos.opacity !== 'undefined') { + dim.opacity = pos < 0.5 ? 0.5 : pos; + } + + wrap.css(dim); + + content.css({ + 'width' : dim.width - currentOpts.padding * 2, + 'height' : dim.height - (titleHeight * pos) - currentOpts.padding * 2 + }); + }, + + _get_viewport = function() { + return [ + $(window).width() - (currentOpts.margin * 2), + $(window).height() - (currentOpts.margin * 2), + $(document).scrollLeft() + currentOpts.margin, + $(document).scrollTop() + currentOpts.margin + ]; + }, + + _get_zoom_to = function () { + var view = _get_viewport(), + to = {}, + resize = currentOpts.autoScale, + double_padding = currentOpts.padding * 2, + ratio; + + if (currentOpts.width.toString().indexOf('%') > -1) { + to.width = parseInt((view[0] * parseFloat(currentOpts.width)) / 100, 10); + } else { + to.width = currentOpts.width + double_padding; + } + + if (currentOpts.height.toString().indexOf('%') > -1) { + to.height = parseInt((view[1] * parseFloat(currentOpts.height)) / 100, 10); + } else { + to.height = currentOpts.height + double_padding; + } + + if (resize && (to.width > view[0] || to.height > view[1])) { + if (selectedOpts.type == 'image' || selectedOpts.type == 'swf') { + ratio = (currentOpts.width ) / (currentOpts.height ); + + if ((to.width ) > view[0]) { + to.width = view[0]; + to.height = parseInt(((to.width - double_padding) / ratio) + double_padding, 10); + } + + if ((to.height) > view[1]) { + to.height = view[1]; + to.width = parseInt(((to.height - double_padding) * ratio) + double_padding, 10); + } + + } else { + to.width = Math.min(to.width, view[0]); + to.height = Math.min(to.height, view[1]); + } + } + + to.top = parseInt(Math.max(view[3] - 20, view[3] + ((view[1] - to.height - 40) * 0.5)), 10); + to.left = parseInt(Math.max(view[2] - 20, view[2] + ((view[0] - to.width - 40) * 0.5)), 10); + + return to; + }, + + _get_obj_pos = function(obj) { + var pos = obj.offset(); + + pos.top += parseInt( obj.css('paddingTop'), 10 ) || 0; + pos.left += parseInt( obj.css('paddingLeft'), 10 ) || 0; + + pos.top += parseInt( obj.css('border-top-width'), 10 ) || 0; + pos.left += parseInt( obj.css('border-left-width'), 10 ) || 0; + + pos.width = obj.width(); + pos.height = obj.height(); + + return pos; + }, + + _get_zoom_from = function() { + var orig = selectedOpts.orig ? $(selectedOpts.orig) : false, + from = {}, + pos, + view; + + if (orig && orig.length) { + pos = _get_obj_pos(orig); + + from = { + width : pos.width + (currentOpts.padding * 2), + height : pos.height + (currentOpts.padding * 2), + top : pos.top - currentOpts.padding - 20, + left : pos.left - currentOpts.padding - 20 + }; + + } else { + view = _get_viewport(); + + from = { + width : currentOpts.padding * 2, + height : currentOpts.padding * 2, + top : parseInt(view[3] + view[1] * 0.5, 10), + left : parseInt(view[2] + view[0] * 0.5, 10) + }; + } + + return from; + }, + + _animate_loading = function() { + if (!loading.is(':visible')){ + clearInterval(loadingTimer); + return; + } + + $('div', loading).css('top', (loadingFrame * -40) + 'px'); + + loadingFrame = (loadingFrame + 1) % 12; + }; + + /* + * Public methods + */ + + $.fn.fancybox = function(options) { + if (!$(this).length) { + return this; + } + + $(this) + .data('fancybox', $.extend({}, options, ($.metadata ? $(this).metadata() : {}))) + .unbind('click.fb') + .bind('click.fb', function(e) { + e.preventDefault(); + + if (busy) { + return; + } + + busy = true; + + $(this).blur(); + + selectedArray = []; + selectedIndex = 0; + + var rel = $(this).attr('rel') || ''; + + if (!rel || rel == '' || rel === 'nofollow') { + selectedArray.push(this); + + } else { + selectedArray = $("a[rel=" + rel + "], area[rel=" + rel + "]"); + selectedIndex = selectedArray.index( this ); + } + + _start(); + + return; + }); + + return this; + }; + + $.fancybox = function(obj) { + var opts; + + if (busy) { + return; + } + + busy = true; + opts = typeof arguments[1] !== 'undefined' ? arguments[1] : {}; + + selectedArray = []; + selectedIndex = parseInt(opts.index, 10) || 0; + + if ($.isArray(obj)) { + for (var i = 0, j = obj.length; i < j; i++) { + if (typeof obj[i] == 'object') { + $(obj[i]).data('fancybox', $.extend({}, opts, obj[i])); + } else { + obj[i] = $({}).data('fancybox', $.extend({content : obj[i]}, opts)); + } + } + + selectedArray = jQuery.merge(selectedArray, obj); + + } else { + if (typeof obj == 'object') { + $(obj).data('fancybox', $.extend({}, opts, obj)); + } else { + obj = $({}).data('fancybox', $.extend({content : obj}, opts)); + } + + selectedArray.push(obj); + } + + if (selectedIndex > selectedArray.length || selectedIndex < 0) { + selectedIndex = 0; + } + + _start(); + }; + + $.fancybox.showActivity = function() { + clearInterval(loadingTimer); + + loading.show(); + loadingTimer = setInterval(_animate_loading, 66); + }; + + $.fancybox.hideActivity = function() { + loading.hide(); + }; + + $.fancybox.next = function() { + return $.fancybox.pos( currentIndex + 1); + }; + + $.fancybox.prev = function() { + return $.fancybox.pos( currentIndex - 1); + }; + + $.fancybox.pos = function(pos) { + if (busy) { + return; + } + + pos = parseInt(pos); + + selectedArray = currentArray; + + if (pos > -1 && pos < currentArray.length) { + selectedIndex = pos; + _start(); + + } else if (currentOpts.cyclic && currentArray.length > 1) { + selectedIndex = pos >= currentArray.length ? 0 : currentArray.length - 1; + _start(); + } + + return; + }; + + $.fancybox.cancel = function() { + if (busy) { + return; + } + + busy = true; + + $.event.trigger('fancybox-cancel'); + + _abort(); + + selectedOpts.onCancel(selectedArray, selectedIndex, selectedOpts); + + busy = false; + }; + + // Note: within an iframe use - parent.$.fancybox.close(); + $.fancybox.close = function() { + if (busy || wrap.is(':hidden')) { + return; + } + + busy = true; + + if (currentOpts && false === currentOpts.onCleanup(currentArray, currentIndex, currentOpts)) { + busy = false; + return; + } + + _abort(); + + $(close.add( nav_left ).add( nav_right )).hide(); + + $(content.add( overlay )).unbind(); + + $(window).unbind("resize.fb scroll.fb"); + $(document).unbind('keydown.fb'); + + content.find('iframe').attr('src', isIE6 && /^https/i.test(window.location.href || '') ? 'javascript:void(false)' : 'about:blank'); + + if (currentOpts.titlePosition !== 'inside') { + title.empty(); + } + + wrap.stop(); + + function _cleanup() { + overlay.fadeOut('fast'); + + title.empty().hide(); + wrap.hide(); + + $.event.trigger('fancybox-cleanup'); + + content.empty(); + + currentOpts.onClosed(currentArray, currentIndex, currentOpts); + + currentArray = selectedOpts = []; + currentIndex = selectedIndex = 0; + currentOpts = selectedOpts = {}; + + busy = false; + } + + if (currentOpts.transitionOut == 'elastic') { + start_pos = _get_zoom_from(); + + var pos = wrap.position(); + + final_pos = { + top : pos.top , + left : pos.left, + width : wrap.width(), + height : wrap.height() + }; + + if (currentOpts.opacity) { + final_pos.opacity = 1; + } + + title.empty().hide(); + + fx.prop = 1; + + $(fx).animate({ prop: 0 }, { + duration : currentOpts.speedOut, + easing : currentOpts.easingOut, + step : _draw, + complete : _cleanup + }); + + } else { + wrap.fadeOut( currentOpts.transitionOut == 'none' ? 0 : currentOpts.speedOut, _cleanup); + } + }; + + $.fancybox.resize = function() { + if (overlay.is(':visible')) { + overlay.css('height', $(document).height()); + } + + $.fancybox.center(true); + }; + + $.fancybox.center = function() { + var view, align; + + if (busy) { + return; + } + + align = arguments[0] === true ? 1 : 0; + view = _get_viewport(); + + if (!align && (wrap.width() > view[0] || wrap.height() > view[1])) { + return; + } + + wrap + .stop() + .animate({ + 'top' : parseInt(Math.max(view[3] - 20, view[3] + ((view[1] - content.height() - 40) * 0.5) - currentOpts.padding)), + 'left' : parseInt(Math.max(view[2] - 20, view[2] + ((view[0] - content.width() - 40) * 0.5) - currentOpts.padding)) + }, typeof arguments[0] == 'number' ? arguments[0] : 200); + }; + + $.fancybox.init = function() { + if ($("#fancybox-wrap").length) { + return; + } + + $('body').append( + tmp = $('

'), + loading = $('

'), + overlay = $('

'), + wrap = $('

') + ); + + outer = $('

') + .append('

') + .appendTo( wrap ); + + outer.append( + content = $('

'), + close = $(''), + title = $('

'), + + nav_left = $(''), + nav_right = $('') + ); + + close.click($.fancybox.close); + loading.click($.fancybox.cancel); + + nav_left.click(function(e) { + e.preventDefault(); + $.fancybox.prev(); + }); + + nav_right.click(function(e) { + e.preventDefault(); + $.fancybox.next(); + }); + + if ($.fn.mousewheel) { + wrap.bind('mousewheel.fb', function(e, delta) { + if (busy) { + e.preventDefault(); + + } else if ($(e.target).get(0).clientHeight == 0 || $(e.target).get(0).scrollHeight === $(e.target).get(0).clientHeight) { + e.preventDefault(); + $.fancybox[ delta > 0 ? 'prev' : 'next'](); + } + }); + } + + if (!$.support.opacity) { + wrap.addClass('fancybox-ie'); + } + + if (isIE6) { + loading.addClass('fancybox-ie6'); + wrap.addClass('fancybox-ie6'); + + $('').prependTo(outer); + } + }; + + $.fn.fancybox.defaults = { + padding : 10, + margin : 40, + opacity : false, + modal : false, + cyclic : false, + scrolling : 'auto', // 'auto', 'yes' or 'no' + + width : 560, + height : 340, + + autoScale : true, + autoDimensions : true, + centerOnScroll : false, + + ajax : {}, + swf : { wmode: 'transparent' }, + + hideOnOverlayClick : true, + hideOnContentClick : false, + + overlayShow : true, + overlayOpacity : 0.7, + overlayColor : '#777', + + titleShow : true, + titlePosition : 'float', // 'float', 'outside', 'inside' or 'over' + titleFormat : null, + titleFromAlt : false, + + transitionIn : 'fade', // 'elastic', 'fade' or 'none' + transitionOut : 'fade', // 'elastic', 'fade' or 'none' + + speedIn : 300, + speedOut : 300, + + changeSpeed : 300, + changeFade : 'fast', + + easingIn : 'swing', + easingOut : 'swing', + + showCloseButton : true, + showNavArrows : true, + enableEscapeButton : true, + enableKeyboardNav : true, + + onStart : function(){}, + onCancel : function(){}, + onComplete : function(){}, + onCleanup : function(){}, + onClosed : function(){}, + onError : function(){} + }; + + $(document).ready(function() { + $.fancybox.init(); + }); + +})(jQuery); ADDED cgisetup/www/css/img/fancybox/jquery.fancybox-1.3.4.pack.js Index: cgisetup/www/css/img/fancybox/jquery.fancybox-1.3.4.pack.js ================================================================== --- /dev/null +++ cgisetup/www/css/img/fancybox/jquery.fancybox-1.3.4.pack.js @@ -0,0 +1,46 @@ +/* + * FancyBox - jQuery Plugin + * Simple and fancy lightbox alternative + * + * Examples and documentation at: http://fancybox.net + * + * Copyright (c) 2008 - 2010 Janis Skarnelis + * That said, it is hardly a one-person project. Many people have submitted bugs, code, and offered their advice freely. Their support is greatly appreciated. + * + * Version: 1.3.4 (11/11/2010) + * Requires: jQuery v1.3+ + * + * Dual licensed under the MIT and GPL licenses: + * http://www.opensource.org/licenses/mit-license.php + * http://www.gnu.org/licenses/gpl.html + */ + +;(function(b){var m,t,u,f,D,j,E,n,z,A,q=0,e={},o=[],p=0,d={},l=[],G=null,v=new Image,J=/\.(jpg|gif|png|bmp|jpeg)(.*)?$/i,W=/[^\.]\.(swf)\s*$/i,K,L=1,y=0,s="",r,i,h=false,B=b.extend(b("

")[0],{prop:0}),M=b.browser.msie&&b.browser.version<7&&!window.XMLHttpRequest,N=function(){t.hide();v.onerror=v.onload=null;G&&G.abort();m.empty()},O=function(){if(false===e.onError(o,q,e)){t.hide();h=false}else{e.titleShow=false;e.width="auto";e.height="auto";m.html('

The requested content cannot be loaded.
Please try again later.

'); +F()}},I=function(){var a=o[q],c,g,k,C,P,w;N();e=b.extend({},b.fn.fancybox.defaults,typeof b(a).data("fancybox")=="undefined"?e:b(a).data("fancybox"));w=e.onStart(o,q,e);if(w===false)h=false;else{if(typeof w=="object")e=b.extend(e,w);k=e.title||(a.nodeName?b(a).attr("title"):a.title)||"";if(a.nodeName&&!e.orig)e.orig=b(a).children("img:first").length?b(a).children("img:first"):b(a);if(k===""&&e.orig&&e.titleFromAlt)k=e.orig.attr("alt");c=e.href||(a.nodeName?b(a).attr("href"):a.href)||null;if(/^(?:javascript)/i.test(c)|| +c=="#")c=null;if(e.type){g=e.type;if(!c)c=e.content}else if(e.content)g="html";else if(c)g=c.match(J)?"image":c.match(W)?"swf":b(a).hasClass("iframe")?"iframe":c.indexOf("#")===0?"inline":"ajax";if(g){if(g=="inline"){a=c.substr(c.indexOf("#"));g=b(a).length>0?"inline":"ajax"}e.type=g;e.href=c;e.title=k;if(e.autoDimensions)if(e.type=="html"||e.type=="inline"||e.type=="ajax"){e.width="auto";e.height="auto"}else e.autoDimensions=false;if(e.modal){e.overlayShow=true;e.hideOnOverlayClick=false;e.hideOnContentClick= +false;e.enableEscapeButton=false;e.showCloseButton=false}e.padding=parseInt(e.padding,10);e.margin=parseInt(e.margin,10);m.css("padding",e.padding+e.margin);b(".fancybox-inline-tmp").unbind("fancybox-cancel").bind("fancybox-change",function(){b(this).replaceWith(j.children())});switch(g){case "html":m.html(e.content);F();break;case "inline":if(b(a).parent().is("#fancybox-content")===true){h=false;break}b('

').hide().insertBefore(b(a)).bind("fancybox-cleanup",function(){b(this).replaceWith(j.children())}).bind("fancybox-cancel", +function(){b(this).replaceWith(m.children())});b(a).appendTo(m);F();break;case "image":h=false;b.fancybox.showActivity();v=new Image;v.onerror=function(){O()};v.onload=function(){h=true;v.onerror=v.onload=null;e.width=v.width;e.height=v.height;b("").attr({id:"fancybox-img",src:v.src,alt:e.title}).appendTo(m);Q()};v.src=c;break;case "swf":e.scrolling="no";C='

";m.html(C);F();break;case "ajax":h=false;b.fancybox.showActivity();e.ajax.win=e.ajax.success;G=b.ajax(b.extend({},e.ajax,{url:c,data:e.ajax.data||{},error:function(x){x.status>0&&O()},success:function(x,H,R){if((typeof R=="object"?R:G).status==200){if(typeof e.ajax.win== +"function"){w=e.ajax.win(c,x,H,R);if(w===false){t.hide();return}else if(typeof w=="string"||typeof w=="object")x=w}m.html(x);F()}}}));break;case "iframe":Q()}}else O()}},F=function(){var a=e.width,c=e.height;a=a.toString().indexOf("%")>-1?parseInt((b(window).width()-e.margin*2)*parseFloat(a)/100,10)+"px":a=="auto"?"auto":a+"px";c=c.toString().indexOf("%")>-1?parseInt((b(window).height()-e.margin*2)*parseFloat(c)/100,10)+"px":c=="auto"?"auto":c+"px";m.wrapInner('

');e.width=m.width();e.height=m.height();Q()},Q=function(){var a,c;t.hide();if(f.is(":visible")&&false===d.onCleanup(l,p,d)){b.event.trigger("fancybox-cancel");h=false}else{h=true;b(j.add(u)).unbind();b(window).unbind("resize.fb scroll.fb");b(document).unbind("keydown.fb");f.is(":visible")&&d.titlePosition!=="outside"&&f.css("height",f.height());l=o;p=q;d=e;if(d.overlayShow){u.css({"background-color":d.overlayColor, +opacity:d.overlayOpacity,cursor:d.hideOnOverlayClick?"pointer":"auto",height:b(document).height()});if(!u.is(":visible")){M&&b("select:not(#fancybox-tmp select)").filter(function(){return this.style.visibility!=="hidden"}).css({visibility:"hidden"}).one("fancybox-cleanup",function(){this.style.visibility="inherit"});u.show()}}else u.hide();i=X();s=d.title||"";y=0;n.empty().removeAttr("style").removeClass();if(d.titleShow!==false){if(b.isFunction(d.titleFormat))a=d.titleFormat(s,l,p,d);else a=s&&s.length? +d.titlePosition=="float"?'

'+s+'

':'

'+s+"

":false;s=a;if(!(!s||s==="")){n.addClass("fancybox-title-"+d.titlePosition).html(s).appendTo("body").show();switch(d.titlePosition){case "inside":n.css({width:i.width-d.padding*2,marginLeft:d.padding,marginRight:d.padding}); +y=n.outerHeight(true);n.appendTo(D);i.height+=y;break;case "over":n.css({marginLeft:d.padding,width:i.width-d.padding*2,bottom:d.padding}).appendTo(D);break;case "float":n.css("left",parseInt((n.width()-i.width-40)/2,10)*-1).appendTo(f);break;default:n.css({width:i.width-d.padding*2,paddingLeft:d.padding,paddingRight:d.padding}).appendTo(f)}}}n.hide();if(f.is(":visible")){b(E.add(z).add(A)).hide();a=f.position();r={top:a.top,left:a.left,width:f.width(),height:f.height()};c=r.width==i.width&&r.height== +i.height;j.fadeTo(d.changeFade,0.3,function(){var g=function(){j.html(m.contents()).fadeTo(d.changeFade,1,S)};b.event.trigger("fancybox-change");j.empty().removeAttr("filter").css({"border-width":d.padding,width:i.width-d.padding*2,height:e.autoDimensions?"auto":i.height-y-d.padding*2});if(c)g();else{B.prop=0;b(B).animate({prop:1},{duration:d.changeSpeed,easing:d.easingChange,step:T,complete:g})}})}else{f.removeAttr("style");j.css("border-width",d.padding);if(d.transitionIn=="elastic"){r=V();j.html(m.contents()); +f.show();if(d.opacity)i.opacity=0;B.prop=0;b(B).animate({prop:1},{duration:d.speedIn,easing:d.easingIn,step:T,complete:S})}else{d.titlePosition=="inside"&&y>0&&n.show();j.css({width:i.width-d.padding*2,height:e.autoDimensions?"auto":i.height-y-d.padding*2}).html(m.contents());f.css(i).fadeIn(d.transitionIn=="none"?0:d.speedIn,S)}}}},Y=function(){if(d.enableEscapeButton||d.enableKeyboardNav)b(document).bind("keydown.fb",function(a){if(a.keyCode==27&&d.enableEscapeButton){a.preventDefault();b.fancybox.close()}else if((a.keyCode== +37||a.keyCode==39)&&d.enableKeyboardNav&&a.target.tagName!=="INPUT"&&a.target.tagName!=="TEXTAREA"&&a.target.tagName!=="SELECT"){a.preventDefault();b.fancybox[a.keyCode==37?"prev":"next"]()}});if(d.showNavArrows){if(d.cyclic&&l.length>1||p!==0)z.show();if(d.cyclic&&l.length>1||p!=l.length-1)A.show()}else{z.hide();A.hide()}},S=function(){if(!b.support.opacity){j.get(0).style.removeAttribute("filter");f.get(0).style.removeAttribute("filter")}e.autoDimensions&&j.css("height","auto");f.css("height","auto"); +s&&s.length&&n.show();d.showCloseButton&&E.show();Y();d.hideOnContentClick&&j.bind("click",b.fancybox.close);d.hideOnOverlayClick&&u.bind("click",b.fancybox.close);b(window).bind("resize.fb",b.fancybox.resize);d.centerOnScroll&&b(window).bind("scroll.fb",b.fancybox.center);if(d.type=="iframe")b('').appendTo(j); +f.show();h=false;b.fancybox.center();d.onComplete(l,p,d);var a,c;if(l.length-1>p){a=l[p+1].href;if(typeof a!=="undefined"&&a.match(J)){c=new Image;c.src=a}}if(p>0){a=l[p-1].href;if(typeof a!=="undefined"&&a.match(J)){c=new Image;c.src=a}}},T=function(a){var c={width:parseInt(r.width+(i.width-r.width)*a,10),height:parseInt(r.height+(i.height-r.height)*a,10),top:parseInt(r.top+(i.top-r.top)*a,10),left:parseInt(r.left+(i.left-r.left)*a,10)};if(typeof i.opacity!=="undefined")c.opacity=a<0.5?0.5:a;f.css(c); +j.css({width:c.width-d.padding*2,height:c.height-y*a-d.padding*2})},U=function(){return[b(window).width()-d.margin*2,b(window).height()-d.margin*2,b(document).scrollLeft()+d.margin,b(document).scrollTop()+d.margin]},X=function(){var a=U(),c={},g=d.autoScale,k=d.padding*2;c.width=d.width.toString().indexOf("%")>-1?parseInt(a[0]*parseFloat(d.width)/100,10):d.width+k;c.height=d.height.toString().indexOf("%")>-1?parseInt(a[1]*parseFloat(d.height)/100,10):d.height+k;if(g&&(c.width>a[0]||c.height>a[1]))if(e.type== +"image"||e.type=="swf"){g=d.width/d.height;if(c.width>a[0]){c.width=a[0];c.height=parseInt((c.width-k)/g+k,10)}if(c.height>a[1]){c.height=a[1];c.width=parseInt((c.height-k)*g+k,10)}}else{c.width=Math.min(c.width,a[0]);c.height=Math.min(c.height,a[1])}c.top=parseInt(Math.max(a[3]-20,a[3]+(a[1]-c.height-40)*0.5),10);c.left=parseInt(Math.max(a[2]-20,a[2]+(a[0]-c.width-40)*0.5),10);return c},V=function(){var a=e.orig?b(e.orig):false,c={};if(a&&a.length){c=a.offset();c.top+=parseInt(a.css("paddingTop"), +10)||0;c.left+=parseInt(a.css("paddingLeft"),10)||0;c.top+=parseInt(a.css("border-top-width"),10)||0;c.left+=parseInt(a.css("border-left-width"),10)||0;c.width=a.width();c.height=a.height();c={width:c.width+d.padding*2,height:c.height+d.padding*2,top:c.top-d.padding-20,left:c.left-d.padding-20}}else{a=U();c={width:d.padding*2,height:d.padding*2,top:parseInt(a[3]+a[1]*0.5,10),left:parseInt(a[2]+a[0]*0.5,10)}}return c},Z=function(){if(t.is(":visible")){b("div",t).css("top",L*-40+"px");L=(L+1)%12}else clearInterval(K)}; +b.fn.fancybox=function(a){if(!b(this).length)return this;b(this).data("fancybox",b.extend({},a,b.metadata?b(this).metadata():{})).unbind("click.fb").bind("click.fb",function(c){c.preventDefault();if(!h){h=true;b(this).blur();o=[];q=0;c=b(this).attr("rel")||"";if(!c||c==""||c==="nofollow")o.push(this);else{o=b("a[rel="+c+"], area[rel="+c+"]");q=o.index(this)}I()}});return this};b.fancybox=function(a,c){var g;if(!h){h=true;g=typeof c!=="undefined"?c:{};o=[];q=parseInt(g.index,10)||0;if(b.isArray(a)){for(var k= +0,C=a.length;ko.length||q<0)q=0;I()}};b.fancybox.showActivity=function(){clearInterval(K);t.show();K=setInterval(Z,66)};b.fancybox.hideActivity=function(){t.hide()};b.fancybox.next=function(){return b.fancybox.pos(p+ +1)};b.fancybox.prev=function(){return b.fancybox.pos(p-1)};b.fancybox.pos=function(a){if(!h){a=parseInt(a);o=l;if(a>-1&&a1){q=a>=l.length?0:l.length-1;I()}}};b.fancybox.cancel=function(){if(!h){h=true;b.event.trigger("fancybox-cancel");N();e.onCancel(o,q,e);h=false}};b.fancybox.close=function(){function a(){u.fadeOut("fast");n.empty().hide();f.hide();b.event.trigger("fancybox-cleanup");j.empty();d.onClosed(l,p,d);l=e=[];p=q=0;d=e={};h=false}if(!(h||f.is(":hidden"))){h= +true;if(d&&false===d.onCleanup(l,p,d))h=false;else{N();b(E.add(z).add(A)).hide();b(j.add(u)).unbind();b(window).unbind("resize.fb scroll.fb");b(document).unbind("keydown.fb");j.find("iframe").attr("src",M&&/^https/i.test(window.location.href||"")?"javascript:void(false)":"about:blank");d.titlePosition!=="inside"&&n.empty();f.stop();if(d.transitionOut=="elastic"){r=V();var c=f.position();i={top:c.top,left:c.left,width:f.width(),height:f.height()};if(d.opacity)i.opacity=1;n.empty().hide();B.prop=1; +b(B).animate({prop:0},{duration:d.speedOut,easing:d.easingOut,step:T,complete:a})}else f.fadeOut(d.transitionOut=="none"?0:d.speedOut,a)}}};b.fancybox.resize=function(){u.is(":visible")&&u.css("height",b(document).height());b.fancybox.center(true)};b.fancybox.center=function(a){var c,g;if(!h){g=a===true?1:0;c=U();!g&&(f.width()>c[0]||f.height()>c[1])||f.stop().animate({top:parseInt(Math.max(c[3]-20,c[3]+(c[1]-j.height()-40)*0.5-d.padding)),left:parseInt(Math.max(c[2]-20,c[2]+(c[0]-j.width()-40)*0.5- +d.padding))},typeof a=="number"?a:200)}};b.fancybox.init=function(){if(!b("#fancybox-wrap").length){b("body").append(m=b('

'),t=b('

'),u=b('

'),f=b('

'));D=b('

').append('

').appendTo(f); +D.append(j=b('

'),E=b(''),n=b('

'),z=b(''),A=b(''));E.click(b.fancybox.close);t.click(b.fancybox.cancel);z.click(function(a){a.preventDefault();b.fancybox.prev()});A.click(function(a){a.preventDefault();b.fancybox.next()}); +b.fn.mousewheel&&f.bind("mousewheel.fb",function(a,c){if(h)a.preventDefault();else if(b(a.target).get(0).clientHeight==0||b(a.target).get(0).scrollHeight===b(a.target).get(0).clientHeight){a.preventDefault();b.fancybox[c>0?"prev":"next"]()}});b.support.opacity||f.addClass("fancybox-ie");if(M){t.addClass("fancybox-ie6");f.addClass("fancybox-ie6");b('').prependTo(D)}}}; +b.fn.fancybox.defaults={padding:10,margin:40,opacity:false,modal:false,cyclic:false,scrolling:"auto",width:560,height:340,autoScale:true,autoDimensions:true,centerOnScroll:false,ajax:{},swf:{wmode:"transparent"},hideOnOverlayClick:true,hideOnContentClick:false,overlayShow:true,overlayOpacity:0.7,overlayColor:"#777",titleShow:true,titlePosition:"float",titleFormat:null,titleFromAlt:false,transitionIn:"fade",transitionOut:"fade",speedIn:300,speedOut:300,changeSpeed:300,changeFade:"fast",easingIn:"swing", +easingOut:"swing",showCloseButton:true,showNavArrows:true,enableEscapeButton:true,enableKeyboardNav:true,onStart:function(){},onCancel:function(){},onComplete:function(){},onCleanup:function(){},onClosed:function(){},onError:function(){}};b(document).ready(function(){b.fancybox.init()})})(jQuery); ADDED cgisetup/www/css/img/fancybox/jquery.mousewheel-3.0.4.pack.js Index: cgisetup/www/css/img/fancybox/jquery.mousewheel-3.0.4.pack.js ================================================================== --- /dev/null +++ cgisetup/www/css/img/fancybox/jquery.mousewheel-3.0.4.pack.js @@ -0,0 +1,14 @@ +/*! Copyright (c) 2010 Brandon Aaron (http://brandonaaron.net) +* Licensed under the MIT License (LICENSE.txt). +* +* Thanks to: http://adomas.org/javascript-mouse-wheel/ for some pointers. +* Thanks to: Mathias Bank(http://www.mathias-bank.de) for a scope bug fix. +* Thanks to: Seamus Leahy for adding deltaX and deltaY +* +* Version: 3.0.4 +* +* Requires: 1.2.2+ +*/ + +(function(d){function g(a){var b=a||window.event,i=[].slice.call(arguments,1),c=0,h=0,e=0;a=d.event.fix(b);a.type="mousewheel";if(a.wheelDelta)c=a.wheelDelta/120;if(a.detail)c=-a.detail/3;e=c;if(b.axis!==undefined&&b.axis===b.HORIZONTAL_AXIS){e=0;h=-1*c}if(b.wheelDeltaY!==undefined)e=b.wheelDeltaY/120;if(b.wheelDeltaX!==undefined)h=-1*b.wheelDeltaX/120;i.unshift(a,c,h,e);return d.event.handle.apply(this,i)}var f=["DOMMouseScroll","mousewheel"];d.event.special.mousewheel={setup:function(){if(this.addEventListener)for(var a= +f.length;a;)this.addEventListener(f[--a],g,false);else this.onmousewheel=g},teardown:function(){if(this.removeEventListener)for(var a=f.length;a;)this.removeEventListener(f[--a],g,false);else this.onmousewheel=null}};d.fn.extend({mousewheel:function(a){return a?this.bind("mousewheel",a):this.trigger("mousewheel")},unmousewheel:function(a){return this.unbind("mousewheel",a)}})})(jQuery); ADDED cgisetup/www/css/img/gray_jean.png Index: cgisetup/www/css/img/gray_jean.png ================================================================== --- /dev/null +++ cgisetup/www/css/img/gray_jean.png cannot compute difference between binary files ADDED cgisetup/www/css/img/icon-arrow-right.png Index: cgisetup/www/css/img/icon-arrow-right.png ================================================================== --- /dev/null +++ cgisetup/www/css/img/icon-arrow-right.png cannot compute difference between binary files ADDED cgisetup/www/css/jquery.fancybox-1.3.4.css Index: cgisetup/www/css/jquery.fancybox-1.3.4.css ================================================================== --- /dev/null +++ cgisetup/www/css/jquery.fancybox-1.3.4.css @@ -0,0 +1,366 @@ +/* + * FancyBox - jQuery Plugin + * Simple and fancy lightbox alternative + * + * Examples and documentation at: http://fancybox.net + * + * Copyright (c) 2008 - 2010 Janis Skarnelis + * That said, it is hardly a one-person project. Many people have submitted bugs, code, and offered their advice freely. Their support is greatly appreciated. + * + * Version: 1.3.4 (11/11/2010) + * Requires: jQuery v1.3+ + * + * Dual licensed under the MIT and GPL licenses: + * http://www.opensource.org/licenses/mit-license.php + * http://www.gnu.org/licenses/gpl.html + */ + +#fancybox-loading { + position: fixed; + top: 50%; + left: 50%; + width: 40px; + height: 40px; + margin-top: -20px; + margin-left: -20px; + cursor: pointer; + overflow: hidden; + z-index: 1104; + display: none; +} + +#fancybox-loading div { + position: absolute; + top: 0; + left: 0; + width: 40px; + height: 480px; + background-image: url('img/fancybox/fancybox.png'); +} + +#fancybox-overlay { + position: absolute; + top: 0; + left: 0; + width: 100%; + z-index: 1100; + display: none; +} + +#fancybox-tmp { + padding: 0; + margin: 0; + border: 0; + overflow: auto; + display: none; +} + +#fancybox-wrap { + position: absolute; + top: 0; + left: 0; + padding: 20px; + z-index: 1101; + outline: none; + display: none; +} + +#fancybox-outer { + position: relative; + width: 100%; + height: 100%; + background: #fff; +} + +#fancybox-wrap, +#fancybox-wrap *{ +-webkit-box-sizing: content-box; /* Safari/Chrome, other WebKit */ +-moz-box-sizing: content-box; /* Firefox, other Gecko */ +box-sizing: content-box; /* Opera/IE 8+ */ +} + +#fancybox-content { + width: 0; + height: 0; + padding: 0; + outline: none; + position: relative; + overflow: hidden; + z-index: 1102; + border: 0 solid #fff; +} + +#fancybox-hide-sel-frame { + position: absolute; + top: 0; + left: 0; + width: 100%; + height: 100%; + background: transparent; + z-index: 1101; +} + +#fancybox-close { + position: absolute; + top: -15px; + right: -15px; + width: 30px; + height: 30px; + background: transparent url('img/fancybox/fancybox.png') -40px 0; + cursor: pointer; + z-index: 1103; + display: none; +} + +#fancybox-error { + color: #444; + font: normal 12px/20px Arial; + padding: 14px; + margin: 0; +} + +#fancybox-img { + width: 100%; + height: 100%; + padding: 0; + margin: 0; + border: none; + outline: none; + line-height: 0; + vertical-align: top; +} + +#fancybox-frame { + width: 100%; + height: 100%; + border: none; + display: block; +} + +#fancybox-left, #fancybox-right { + position: absolute; + bottom: 0; + height: 100%; + width: 35%; + cursor: pointer; + outline: none; + background: transparent url('img/fancybox/blank.gif'); + z-index: 1102; + display: none; +} + +#fancybox-left { + left: 0; +} + +#fancybox-right { + right: 0; +} + +#fancybox-left-ico, #fancybox-right-ico { + position: absolute; + top: 50%; + left: -9999px; + width: 30px; + height: 30px; + margin-top: -15px; + cursor: pointer; + z-index: 1102; + display: block; +} + +#fancybox-left-ico { + background-image: url('img/fancybox/fancybox.png'); + background-position: -40px -30px; +} + +#fancybox-right-ico { + background-image: url('img/fancybox/fancybox.png'); + background-position: -40px -60px; +} + +#fancybox-left:hover, #fancybox-right:hover { + visibility: visible; /* IE6 */ +} + +#fancybox-left:hover span { + left: 20px; +} + +#fancybox-right:hover span { + left: auto; + right: 20px; +} + +.fancybox-bg { + position: absolute; + padding: 0; + margin: 0; + border: 0; + width: 20px; + height: 20px; + z-index: 1001; +} + +#fancybox-bg-n { + top: -20px; + left: 0; + width: 100%; + background-image: url('img/fancybox/fancybox-x.png'); +} + +#fancybox-bg-ne { + top: -20px; + right: -20px; + background-image: url('img/fancybox/fancybox.png'); + background-position: -40px -162px; +} + +#fancybox-bg-e { + top: 0; + right: -20px; + height: 100%; + background-image: url('img/fancybox/fancybox-y.png'); + background-position: -20px 0; +} + +#fancybox-bg-se { + bottom: -20px; + right: -20px; + background-image: url('img/fancybox/fancybox.png'); + background-position: -40px -182px; +} + +#fancybox-bg-s { + bottom: -20px; + left: 0; + width: 100%; + background-image: url('img/fancybox/fancybox-x.png'); + background-position: 0 -20px; +} + +#fancybox-bg-sw { + bottom: -20px; + left: -20px; + background-image: url('img/fancybox/fancybox.png'); + background-position: -40px -142px; +} + +#fancybox-bg-w { + top: 0; + left: -20px; + height: 100%; + background-image: url('img/fancybox/fancybox-y.png'); +} + +#fancybox-bg-nw { + top: -20px; + left: -20px; + background-image: url('img/fancybox/fancybox.png'); + background-position: -40px -122px; +} + +#fancybox-title { + font-family: Helvetica; + font-size: 12px; + z-index: 1102; +} + +.fancybox-title-inside { + padding-bottom: 10px; + text-align: center; + color: #333; + background: #fff; + position: relative; +} + +.fancybox-title-outside { + padding-top: 10px; + color: #fff; +} + +.fancybox-title-over { + position: absolute; + bottom: 0; + left: 0; + color: #FFF; + text-align: left; +} + +#fancybox-title-over { + padding: 10px; + background-image: url('img/fancybox/fancy_title_over.png'); + display: block; +} + +.fancybox-title-float { + position: absolute; + left: 0; + bottom: -20px; + height: 32px; +} + +#fancybox-title-float-wrap { + border: none; + border-collapse: collapse; + width: auto; +} + +#fancybox-title-float-wrap td { + border: none; + white-space: nowrap; +} + +#fancybox-title-float-left { + padding: 0 0 0 15px; + background: url('img/fancybox/fancybox.png') -40px -90px no-repeat; +} + +#fancybox-title-float-main { + color: #FFF; + line-height: 29px; + font-weight: bold; + padding: 0 0 3px 0; + background: url('img/fancybox/fancybox-x.png') 0 -40px; +} + +#fancybox-title-float-right { + padding: 0 0 0 15px; + background: url('img/fancybox/fancybox.png') -55px -90px no-repeat; +} + +/* IE6 */ + +.fancybox-ie6 #fancybox-close { background: transparent; filter: progid:DXImageTransform.Microsoft.AlphaImageLoader(src='img/fancybox/fancy_close.png', sizingMethod='scale'); } + +.fancybox-ie6 #fancybox-left-ico { background: transparent; filter: progid:DXImageTransform.Microsoft.AlphaImageLoader(src='img/fancybox/fancy_nav_left.png', sizingMethod='scale'); } +.fancybox-ie6 #fancybox-right-ico { background: transparent; filter: progid:DXImageTransform.Microsoft.AlphaImageLoader(src='img/fancybox/fancy_nav_right.png', sizingMethod='scale'); } + +.fancybox-ie6 #fancybox-title-over { background: transparent; filter: progid:DXImageTransform.Microsoft.AlphaImageLoader(src='img/fancybox/fancy_title_over.png', sizingMethod='scale'); zoom: 1; } +.fancybox-ie6 #fancybox-title-float-left { background: transparent; filter: progid:DXImageTransform.Microsoft.AlphaImageLoader(src='img/fancybox/fancy_title_left.png', sizingMethod='scale'); } +.fancybox-ie6 #fancybox-title-float-main { background: transparent; filter: progid:DXImageTransform.Microsoft.AlphaImageLoader(src='img/fancybox/fancy_title_main.png', sizingMethod='scale'); } +.fancybox-ie6 #fancybox-title-float-right { background: transparent; filter: progid:DXImageTransform.Microsoft.AlphaImageLoader(src='img/fancybox/fancy_title_right.png', sizingMethod='scale'); } + +.fancybox-ie6 #fancybox-bg-w, .fancybox-ie6 #fancybox-bg-e, .fancybox-ie6 #fancybox-left, .fancybox-ie6 #fancybox-right, #fancybox-hide-sel-frame { + height: expression(this.parentNode.clientHeight + "px"); +} + +#fancybox-loading.fancybox-ie6 { + position: absolute; margin-top: 0; + top: expression( (-20 + (document.documentElement.clientHeight ? document.documentElement.clientHeight/2 : document.body.clientHeight/2 ) + ( ignoreMe = document.documentElement.scrollTop ? document.documentElement.scrollTop : document.body.scrollTop )) + 'px'); +} + +#fancybox-loading.fancybox-ie6 div { background: transparent; filter: progid:DXImageTransform.Microsoft.AlphaImageLoader(src='img/fancybox/fancy_loading.png', sizingMethod='scale'); } + +/* IE6, IE7, IE8 */ + +.fancybox-ie .fancybox-bg { background: transparent !important; } + +.fancybox-ie #fancybox-bg-n { filter: progid:DXImageTransform.Microsoft.AlphaImageLoader(src='img/fancybox/fancy_shadow_n.png', sizingMethod='scale'); } +.fancybox-ie #fancybox-bg-ne { filter: progid:DXImageTransform.Microsoft.AlphaImageLoader(src='img/fancybox/fancy_shadow_ne.png', sizingMethod='scale'); } +.fancybox-ie #fancybox-bg-e { filter: progid:DXImageTransform.Microsoft.AlphaImageLoader(src='img/fancybox/fancy_shadow_e.png', sizingMethod='scale'); } +.fancybox-ie #fancybox-bg-se { filter: progid:DXImageTransform.Microsoft.AlphaImageLoader(src='img/fancybox/fancy_shadow_se.png', sizingMethod='scale'); } +.fancybox-ie #fancybox-bg-s { filter: progid:DXImageTransform.Microsoft.AlphaImageLoader(src='img/fancybox/fancy_shadow_s.png', sizingMethod='scale'); } +.fancybox-ie #fancybox-bg-sw { filter: progid:DXImageTransform.Microsoft.AlphaImageLoader(src='img/fancybox/fancy_shadow_sw.png', sizingMethod='scale'); } +.fancybox-ie #fancybox-bg-w { filter: progid:DXImageTransform.Microsoft.AlphaImageLoader(src='img/fancybox/fancy_shadow_w.png', sizingMethod='scale'); } +.fancybox-ie #fancybox-bg-nw { filter: progid:DXImageTransform.Microsoft.AlphaImageLoader(src='img/fancybox/fancy_shadow_nw.png', sizingMethod='scale'); } ADDED cgisetup/www/css/kickstart-buttons.css Index: cgisetup/www/css/kickstart-buttons.css ================================================================== --- /dev/null +++ cgisetup/www/css/kickstart-buttons.css @@ -0,0 +1,369 @@ +/* + 99Lime.com HTML KickStart by Joshua Gatcke + kickstart-buttons.css + + Super Easy Cross Browser CSS3 Gradients + http://www.colorzilla.com/gradient-editor/ +*/ + +/*--------------------------------- + BUTTONS +-----------------------------------*/ +button, +a.btn, +a.btn:visited, +a.button, +a.button:visited, +input[type="submit"], +input[type="reset"], +input[type="button"]{ +position:relative; +top:0; +left:0; +vertical-align: middle; +margin:0; +padding:10px 15px; +line-height:100%; +-moz-border-radius:5px; +-webkit-border-radius:5px; +border-radius:5px; +cursor: pointer; +width:auto; +overflow:visible; +font-weight:normal; +font-size:14px; /*Pixels for consistancy*/ +text-shadow:0 1px 0 #fff; +color:#666; +text-decoration:none; +vertical-align: middle; +-webkit-box-sizing: border-box; +-moz-box-sizing: border-box; +box-sizing: border-box; +display:inline-block; +*display:inline;/*IE ONLY*/ +zoom:1; +border:1px solid #ccc; +background: rgb(252,252,252); /* Old browsers */ +background: -moz-linear-gradient(top, rgba(252,252,252,1) 0%, rgba(224,224,224,1) 100%); /* FF3.6+ */ +background: -webkit-gradient(linear, left top, left bottom, color-stop(0%,rgba(252,252,252,1)), color-stop(100%,rgba(224,224,224,1))); /* Chrome,Safari4+ */ +background: -webkit-linear-gradient(top, rgba(252,252,252,1) 0%,rgba(224,224,224,1) 100%); /* Chrome10+,Safari5.1+ */ +background: -o-linear-gradient(top, rgba(252,252,252,1) 0%,rgba(224,224,224,1) 100%); /* Opera11.10+ */ +filter: progid:DXImageTransform.Microsoft.gradient( startColorstr='#fcfcfc', endColorstr='#e0e0e0',GradientType=0 ); /* IE6-9 */ +background: linear-gradient(top, rgba(252,252,252,1) 0%,rgba(224,224,224,1) 100%); /* W3C */ +} + +button:active, +a.btn:active, +a.btn:visited:active, +a.button:active, +a.button:visited:active, +input[type="submit"]:active, +input[type="reset"]:active, +input[type="button"]:active{-webkit-box-shadow:inset 0 3px 5px rgba(0,0,0,0.2),inset 0 -10px 20px rgba(0,0,0,0.07);-moz-box-shadow:inset 0 3px 5px rgba(0,0,0,0.2),inset 0 -10px 20px rgba(0,0,0,0.07);box-shadow:inset 0 3px 5px rgba(0,0,0,0.2),inset 0 -10px 20px rgba(0,0,0,0.07);} +button[disabled],.disabled:active{-webkit-box-shadow:none;-moz-box-shadow:none;box-shadow:none;} + +button, +input[type="submit"], +input[type="reset"], +input[type="button"]{*padding:7px 15px;}/*IE 7 ONLY*/ + + a.btn,a.button{}/*overrides*/ + button.small, a.btn.small, a.button.small{font-size:0.8em;padding:5px 10px;} + button.medium, a.btn.medium, a.button.medium{}/*default*/ + button.large, a.btn.large, a.button.large{font-size:1.3em;padding:10px 20px;} + button.disabled, a.btn.disabled, a.button.disabled{color:#ccc;cursor:default;background:#efefef;} + button.disabled:hover, a.btn.disabled:hover, a.button.disabled:hover{border:1px solid #ccc;background:#efefef;} + + button:hover, + a.btn:hover, + a.button:hover, + input[type="submit"]:hover, + input[type="reset"]:hover, + input[type="button"]:hover{ + border:1px solid #bbb; + background: rgb(252,252,252); /* Old browsers */ + background: -moz-linear-gradient(top, rgba(252,252,252,1) 0%, rgba(237,237,237,1) 100%); /* FF3.6+ */ + background: -webkit-gradient(linear, left top, left bottom, color-stop(0%,rgba(252,252,252,1)), color-stop(100%,rgba(237,237,237,1))); /* Chrome,Safari4+ */ + background: -webkit-linear-gradient(top, rgba(252,252,252,1) 0%,rgba(237,237,237,1) 100%); /* Chrome10+,Safari5.1+ */ + background: -o-linear-gradient(top, rgba(252,252,252,1) 0%,rgba(237,237,237,1) 100%); /* Opera11.10+ */ + filter: progid:DXImageTransform.Microsoft.gradient( startColorstr='#fcfcfc', endColorstr='#ededed',GradientType=0 ); /* IE6-9 */ + background: linear-gradient(top, rgba(252,252,252,1) 0%,rgba(237,237,237,1) 100%); /* W3C */ + } + + +/*--------------------------------- + BUTTON BAR +-----------------------------------*/ +ul.button-bar{ +display:inline-block; +*display:inline; +margin:0; +padding:0; +font-size:0; +position:relative; +top:0; +left:0; +zoom:1; +border:0; +background:0; +} + + ul.button-bar li{ + display:inline-block; + *display:inline; + position:relative; + top:0; + left:0; + zoom:1; + margin:0 -1px 0 0; + padding:0; + line-height:100%; + font-size:0px; + border:1px solid #ccc; + background: rgb(252,252,252); /* Old browsers */ + background: -moz-linear-gradient(top, rgba(252,252,252,1) 0%, rgba(224,224,224,1) 100%); /* FF3.6+ */ + background: -webkit-gradient(linear, left top, left bottom, color-stop(0%,rgba(252,252,252,1)), color-stop(100%,rgba(224,224,224,1))); /* Chrome,Safari4+ */ + background: -webkit-linear-gradient(top, rgba(252,252,252,1) 0%,rgba(224,224,224,1) 100%); /* Chrome10+,Safari5.1+ */ + background: -o-linear-gradient(top, rgba(252,252,252,1) 0%,rgba(224,224,224,1) 100%); /* Opera11.10+ */ + filter: progid:DXImageTransform.Microsoft.gradient( startColorstr='#fcfcfc', endColorstr='#e0e0e0',GradientType=0 ); /* IE6-9 */ + background: linear-gradient(top, rgba(252,252,252,1) 0%,rgba(224,224,224,1) 100%); /* W3C */ + } + + ul.button-bar li a{ + margin:0; + display:inline-block; + *display:inline; + padding:7px 10px; + position:relative; + top:0; + left:0; + zoom:1; + font-weight:normal; + font-size:14px; /*Pixels for consistancy*/ + text-shadow:0 1px 0 #fff; + color:#666; + text-decoration:none; + vertical-align: middle; + line-height:100%; + border-left:1px solid #fff; + } + + ul.button-bar li.first, + ul.button-bar li.first a{ + -moz-border-radius-bottomleft: 5px; + -moz-border-radius-topleft: 5px; + -webkit-border-bottom-left-radius: 5px; + -webkit-border-top-left-radius: 5px; + border-top-left-radius: 5px; + border-bottom-left-radius: 5px; + -moz-background-clip:content-box; + -webkit-background-clip: border; + background-clip: content-box; + } + + ul.button-bar li.last, + ul.button-bar li.last a{ + -moz-border-radius-bottomright: 5px; + -moz-border-radius-topright: 5px; + -webkit-border-bottom-right-radius: 5px; + -webkit-border-top-right-radius: 5px; + border-top-right-radius: 5px; + border-bottom-right-radius: 5px; + -moz-background-clip:content-box; + -webkit-background-clip: border; + } + + ul.button-bar li a:hover{ + background: rgb(252,252,252); /* Old browsers */ + background: -moz-linear-gradient(top, rgba(252,252,252,1) 0%, rgba(237,237,237,1) 100%); /* FF3.6+ */ + background: -webkit-gradient(linear, left top, left bottom, color-stop(0%,rgba(252,252,252,1)), color-stop(100%,rgba(237,237,237,1))); /* Chrome,Safari4+ */ + background: -webkit-linear-gradient(top, rgba(252,252,252,1) 0%,rgba(237,237,237,1) 100%); /* Chrome10+,Safari5.1+ */ + background: -o-linear-gradient(top, rgba(252,252,252,1) 0%,rgba(237,237,237,1) 100%); /* Opera11.10+ */ + filter: progid:DXImageTransform.Microsoft.gradient( startColorstr='#fcfcfc', endColorstr='#ededed',GradientType=0 ); /* IE6-9 */ + background: linear-gradient(top, rgba(252,252,252,1) 0%,rgba(237,237,237,1) 100%); /* W3C */ + } + + ul.button-bar li a:active{-webkit-box-shadow:inset 0 3px 5px rgba(0,0,0,0.2),inset 0 -10px 20px rgba(0,0,0,0.07);-moz-box-shadow:inset 0 3px 5px rgba(0,0,0,0.2),inset 0 -10px 20px rgba(0,0,0,0.07);box-shadow:inset 0 3px 5px rgba(0,0,0,0.2),inset 0 -10px 20px rgba(0,0,0,0.07);border-left:1px solid #ccc;} + +/*--------------------------------- + STYLES +-----------------------------------*/ +.pill{-webkit-border-radius:200em;-moz-border-radius:200em;border-radius:200em;} +.pop{-webkit-box-shadow:0px 1px 5px rgba(0,0,0,0.2);-moz-box-shadow:0px 1px 5px rgba(0,0,0,0.2);box-shadow:0px 1px 5px rgba(0,0,0,0.2);} +.inset{-webkit-box-shadow:inset 0 1px 3px rgba(0,0,0,0.3);-moz-box-shadow:inset 0 1px 3px rgba(0,0,0,0.3);box-shadow:inset 0 1px 3px rgba(0,0,0,0.3);} +.square{-moz-border-radius:0;-webkit-border-radius:0;border-radius:0;} + +/*--------------------------------- + ORANGE +-----------------------------------*/ +button.orange, +a.btn.orange, +a.button.orange, +input[type=submit].orange, +input[type=reset].orange, +input[type=button].orange{ +text-shadow:0 -1px 0 #FC730A; +color:#fff; +border:1px solid #FC730A; +background: rgb(255,168,76); /* Old browsers */ +background: -moz-linear-gradient(top, rgba(255,168,76,1) 0%, rgba(255,123,13,1) 100%); /* FF3.6+ */ +background: -webkit-gradient(linear, left top, left bottom, color-stop(0%,rgba(255,168,76,1)), color-stop(100%,rgba(255,123,13,1))); /* Chrome,Safari4+ */ +background: -webkit-linear-gradient(top, rgba(255,168,76,1) 0%,rgba(255,123,13,1) 100%); /* Chrome10+,Safari5.1+ */ +background: -o-linear-gradient(top, rgba(255,168,76,1) 0%,rgba(255,123,13,1) 100%); /* Opera 11.10+ */ +background: linear-gradient(top, rgba(255,168,76,1) 0%,rgba(255,123,13,1) 100%); /* W3C */ +filter: progid:DXImageTransform.Microsoft.gradient( startColorstr='#ffa84c', endColorstr='#ff7b0d',GradientType=0 ); /* IE6-9 */ +} + + button.orange:hover, + a.btn.orange:hover, + a.button.orange:hover{ + text-shadow:0 1px 0 #FC730A; + border:1px solid #FC730A; + background: rgb(249,191,74); /* Old browsers */ + background: -moz-linear-gradient(top, rgba(249,191,74,1) 0%, rgba(249,181,9,1) 100%); /* FF3.6+ */ + background: -webkit-gradient(linear, left top, left bottom, color-stop(0%,rgba(249,191,74,1)), color-stop(100%,rgba(249,181,9,1))); /* Chrome,Safari4+ */ + background: -webkit-linear-gradient(top, rgba(249,191,74,1) 0%,rgba(249,181,9,1) 100%); /* Chrome10+,Safari5.1+ */ + background: -o-linear-gradient(top, rgba(249,191,74,1) 0%,rgba(249,181,9,1) 100%); /* Opera 11.10+ */ + background: linear-gradient(top, rgba(249,191,74,1) 0%,rgba(249,181,9,1) 100%); /* W3C */ + filter: progid:DXImageTransform.Microsoft.gradient( startColorstr='#f9bf4a', endColorstr='#f9b509',GradientType=0 ); /* IE6-9 */ + } + +/*--------------------------------- + BLUE +-----------------------------------*/ +button.blue, +a.btn.blue, +a.button.blue, +input[type=submit].blue, +input[type=reset].blue, +input[type=button].blue{ +text-shadow:0 -1px 0 #1D6DC1; +color:#fff; +border:1px solid #1D6DC1; +background: rgb(122,188,255); /* Old browsers */ +background: -moz-linear-gradient(top, rgba(122,188,255,1) 0%, rgba(96,171,248,1) 44%, rgba(64,150,238,1) 100%); /* FF3.6+ */ +background: -webkit-gradient(linear, left top, left bottom, color-stop(0%,rgba(122,188,255,1)), color-stop(44%,rgba(96,171,248,1)), color-stop(100%,rgba(64,150,238,1))); /* Chrome,Safari4+ */ +background: -webkit-linear-gradient(top, rgba(122,188,255,1) 0%,rgba(96,171,248,1) 44%,rgba(64,150,238,1) 100%); /* Chrome10+,Safari5.1+ */ +background: -o-linear-gradient(top, rgba(122,188,255,1) 0%,rgba(96,171,248,1) 44%,rgba(64,150,238,1) 100%); /* Opera11.10+ */ +filter: progid:DXImageTransform.Microsoft.gradient( startColorstr='#7abcff', endColorstr='#4096ee',GradientType=0 ); /* IE6-9 */ +background: linear-gradient(top, rgba(122,188,255,1) 0%,rgba(96,171,248,1) 44%,rgba(64,150,238,1) 100%); /* W3C */ +} + + button.blue:hover, + a.btn.blue:hover, + a.button.blue:hover{ + text-shadow:0 1px 0 #1D6DC1; + border:1px solid #1D6DC1; + background: rgb(155,205,255); /* Old browsers */ + background: -moz-linear-gradient(top, rgba(155,205,255,1) 0%, rgba(134,192,250,1) 44%, rgba(110,176,242,1) 100%); /* FF3.6+ */ + background: -webkit-gradient(linear, left top, left bottom, color-stop(0%,rgba(155,205,255,1)), color-stop(44%,rgba(134,192,250,1)), color-stop(100%,rgba(110,176,242,1))); /* Chrome,Safari4+ */ + background: -webkit-linear-gradient(top, rgba(155,205,255,1) 0%,rgba(134,192,250,1) 44%,rgba(110,176,242,1) 100%); /* Chrome10+,Safari5.1+ */ + background: -o-linear-gradient(top, rgba(155,205,255,1) 0%,rgba(134,192,250,1) 44%,rgba(110,176,242,1) 100%); /* Opera 11.10+ */ + background: linear-gradient(top, rgba(155,205,255,1) 0%,rgba(134,192,250,1) 44%,rgba(110,176,242,1) 100%); /* W3C */ + filter: progid:DXImageTransform.Microsoft.gradient( startColorstr='#9bcdff', endColorstr='#6eb0f2',GradientType=0 ); /* IE6-9 */ + } + +/*--------------------------------- + PINK +-----------------------------------*/ +button.pink, +a.btn.pink, +a.button.pink, +input[type=submit].pink, +input[type=reset].pink, +input[type=button].pink{ +text-shadow:0 -1px 0 #EF0251; +color:#fff; +border:1px solid #EF0251; +background: rgb(255,93,177); /* Old browsers */ +background: -moz-linear-gradient(top, rgba(255,93,177,1) 0%, rgba(239,1,124,1) 100%); /* FF3.6+ */ +background: -webkit-gradient(linear, left top, left bottom, color-stop(0%,rgba(255,93,177,1)), color-stop(100%,rgba(239,1,124,1))); /* Chrome,Safari4+ */ +background: -webkit-linear-gradient(top, rgba(255,93,177,1) 0%,rgba(239,1,124,1) 100%); /* Chrome10+,Safari5.1+ */ +background: -o-linear-gradient(top, rgba(255,93,177,1) 0%,rgba(239,1,124,1) 100%); /* Opera 11.10+ */ +background: linear-gradient(top, rgba(255,93,177,1) 0%,rgba(239,1,124,1) 100%); /* W3C */ +filter: progid:DXImageTransform.Microsoft.gradient( startColorstr='#ff5db1', endColorstr='#ef017c',GradientType=0 ); /* IE6-9 */ +} + + button.pink:hover, + a.btn.pink:hover, + a.button.pink:hover{ + text-shadow:0 1px 0 #EF0251; + border:1px solid #EF0251; + background: rgb(255,169,213); /* Old browsers */ + background: -moz-linear-gradient(top, rgba(255,169,213,1) 0%, rgba(254,112,185,1) 100%); /* FF3.6+ */ + background: -webkit-gradient(linear, left top, left bottom, color-stop(0%,rgba(255,169,213,1)), color-stop(100%,rgba(254,112,185,1))); /* Chrome,Safari4+ */ + background: -webkit-linear-gradient(top, rgba(255,169,213,1) 0%,rgba(254,112,185,1) 100%); /* Chrome10+,Safari5.1+ */ + background: -o-linear-gradient(top, rgba(255,169,213,1) 0%,rgba(254,112,185,1) 100%); /* Opera 11.10+ */ + background: linear-gradient(top, rgba(255,169,213,1) 0%,rgba(254,112,185,1) 100%); /* W3C */ + filter: progid:DXImageTransform.Microsoft.gradient( startColorstr='#ffa9d5', endColorstr='#fe70b9',GradientType=0 ); /* IE6-9 */ + } + +/*--------------------------------- + GREEN +-----------------------------------*/ +button.green, +a.btn.green, +a.button.green, +input[type=submit].green, +input[type=reset].green, +input[type=button].green{ +text-shadow:0 -1px 0 #669E00; +color:#fff; +border:1px solid #669E00; +background: rgb(143,196,0); /* Old browsers */ +background: -moz-linear-gradient(top, rgba(143,196,0,1) 0%, rgba(107,165,0,1) 100%); /* FF3.6+ */ +background: -webkit-gradient(linear, left top, left bottom, color-stop(0%,rgba(143,196,0,1)), color-stop(100%,rgba(107,165,0,1))); /* Chrome,Safari4+ */ +background: -webkit-linear-gradient(top, rgba(143,196,0,1) 0%,rgba(107,165,0,1) 100%); /* Chrome10+,Safari5.1+ */ +background: -o-linear-gradient(top, rgba(143,196,0,1) 0%,rgba(107,165,0,1) 100%); /* Opera 11.10+ */ +background: linear-gradient(top, rgba(143,196,0,1) 0%,rgba(107,165,0,1) 100%); /* W3C */ +filter: progid:DXImageTransform.Microsoft.gradient( startColorstr='#8fc400', endColorstr='#6ba500',GradientType=0 ); /* IE6-9 */ +} + + button.green:hover, + a.btn.green:hover, + a.button.green:hover{ + text-shadow:0 1px 0 #669E00; + border:1px solid #669E00; + background: rgb(198,226,120); /* Old browsers */ + background: -moz-linear-gradient(top, rgba(198,226,120,1) 0%, rgba(167,211,44,1) 100%); /* FF3.6+ */ + background: -webkit-gradient(linear, left top, left bottom, color-stop(0%,rgba(198,226,120,1)), color-stop(100%,rgba(167,211,44,1))); /* Chrome,Safari4+ */ + background: -webkit-linear-gradient(top, rgba(198,226,120,1) 0%,rgba(167,211,44,1) 100%); /* Chrome10+,Safari5.1+ */ + background: -o-linear-gradient(top, rgba(198,226,120,1) 0%,rgba(167,211,44,1) 100%); /* Opera 11.10+ */ + background: linear-gradient(top, rgba(198,226,120,1) 0%,rgba(167,211,44,1) 100%); /* W3C */ + filter: progid:DXImageTransform.Microsoft.gradient( startColorstr='#c6e278', endColorstr='#a7d32c',GradientType=0 ); /* IE6-9 */ + } + +/*--------------------------------- + RED +-----------------------------------*/ +button.red, +a.btn.red, +a.button.red, +input[type=submit].red, +input[type=reset].red, +input[type=button].red{ +text-shadow:0 -1px 0 #B21203; +color:#fff; +border:1px solid #B21203; +background: rgb(229,60,22); /* Old browsers */ +background: -moz-linear-gradient(top, rgba(229,60,22,1) 0%, rgba(207,4,4,1) 100%); /* FF3.6+ */ +background: -webkit-gradient(linear, left top, left bottom, color-stop(0%,rgba(229,60,22,1)), color-stop(100%,rgba(207,4,4,1))); /* Chrome,Safari4+ */ +background: -webkit-linear-gradient(top, rgba(229,60,22,1) 0%,rgba(207,4,4,1) 100%); /* Chrome10+,Safari5.1+ */ +background: -o-linear-gradient(top, rgba(229,60,22,1) 0%,rgba(207,4,4,1) 100%); /* Opera 11.10+ */ +background: linear-gradient(top, rgba(229,60,22,1) 0%,rgba(207,4,4,1) 100%); /* W3C */ +filter: progid:DXImageTransform.Microsoft.gradient( startColorstr='#e53c16', endColorstr='#cf0404',GradientType=0 ); /* IE6-9 */ +} + + button.red:hover, + a.btn.red:hover, + a.button.red:hover{ + text-shadow:0 1px 0 #B21203; + border:1px solid #B21203; + background: rgb(238,106,76); /* Old browsers */ + background: -moz-linear-gradient(top, rgba(238,106,76,1) 0%, rgba(251,33,33,1) 100%); /* FF3.6+ */ + background: -webkit-gradient(linear, left top, left bottom, color-stop(0%,rgba(238,106,76,1)), color-stop(100%,rgba(251,33,33,1))); /* Chrome,Safari4+ */ + background: -webkit-linear-gradient(top, rgba(238,106,76,1) 0%,rgba(251,33,33,1) 100%); /* Chrome10+,Safari5.1+ */ + background: -o-linear-gradient(top, rgba(238,106,76,1) 0%,rgba(251,33,33,1) 100%); /* Opera 11.10+ */ + background: linear-gradient(top, rgba(238,106,76,1) 0%,rgba(251,33,33,1) 100%); /* W3C */ + filter: progid:DXImageTransform.Microsoft.gradient( startColorstr='#ee6a4c', endColorstr='#fb2121',GradientType=0 ); /* IE6-9 */ + } ADDED cgisetup/www/css/kickstart-forms.css Index: cgisetup/www/css/kickstart-forms.css ================================================================== --- /dev/null +++ cgisetup/www/css/kickstart-forms.css @@ -0,0 +1,290 @@ +/*--------------------------------- + FORMS +-----------------------------------*/ +form{ +padding:0; +margin:0; +} + +fieldset{ +margin:30px 0 20px 0; +padding:5px 15px 15px 15px; +border:1px solid #ccc; +background:#f5f5f5; +-moz-border-radius:5px; +-webkit-border-radius:5px; +border-radius:5px; +position: relative; +top:0; +left:0; +} + + legend{ + -moz-border-radius:5px; + -webkit-border-radius:5px; + border-radius:5px; + border:1px solid #ccc; + background:#f5f5f5; + padding:2px 10px; + margin:0 0 0 0; + display:block; + position: relative; + top:0; + left:0; + } + + /*IE ONLY - I know, this is a stop gap*/ + .msie fieldset{padding-top:25px;} + .msie legend{position:absolute;top:-0.7em;left:10px;} + +label{ +display:inline-block; +*display:inline; +vertical-align: middle; +margin:0; +padding:0; +position:relative; +top:0; +left:0; +zoom:1; +-moz-box-sizing: border-box; +-webkit-box-sizing: border-box; +box-sizing: border-box; +} + + label.inline{ + display:inline; + margin:0; + } + + label span{ + color:#999; + font-size:0.9em; + } + + label span.right{ + position:absolute; + bottom:0; + right:0; + text-align:right; + display:inline-block; + *display:inline; + } + + label.disabled{ + color:#ccc; + } + +input{ +display:inline-block; +*display:inline; +vertical-align: middle; +width:auto; +zoom:1; +margin:0; +border:1px solid #ccc; +font-size:1em; +padding:5px 0; +text-indent: 5px; +-moz-border-radius:5px; +-webkit-border-radius:5px; +border-radius:5px; +background:#fff; +-moz-box-shadow:inset 0 0 6px #ccc; +-webkit-box-shadow:inset 0 1px 6px #ccc; +box-shadow:inset 0 1px 6px #ccc; +-moz-box-sizing: border-box; +-webkit-box-sizing: border-box; +box-sizing: border-box; +} + + input::-webkit-input-placeholder, + input:-moz-placeholder, + .placeholder{ + color:#bbb; + } + + input::-moz-focus-inner {border:0;} + + input[disabled="disabled"], input.disabled{ + color:#999; + background:#f5f5f5; + -moz-box-shadow:inset 0 0 2px #ddd; + -webkit-box-shadow:inset 0 1px 2px #ddd; + box-shadow:inset 0 1px 2px #ddd; + } + + /* FOCUS STATES */ + input[type="text"]:focus, + textarea:focus, + button:focus, + a.button:focus, + select:focus, + input[type="file"]:focus, + input[type="password"]:focus{ + -webkit-box-shadow: 0 0 7px #6DB9FF; + -moz-box-shadow : 0 0 7px #6DB9FF; + box-shadow : 0 0 7px #6DB9FF; + border: 1px solid #50B1FE; + outline: none; + } + + /* TRANSITION */ + input[type="text"], + textarea, + button, + a.button, + a, + input[type="file"]{ + -moz-transition: -moz-box-shadow 0.5s, border 0.5s, background 0.5s; + -webkit-transition: -webkit-box-shadow 0.5s, border 0.5s, background 0.5s; + -o-transition: box-shadow 0.5s, border 0.5s, background 0.5s; + transition: box-shadow 0.5s, border 0.5s, background 0.5s; + } + +input.checkbox, +input[type="checkbox"]{ +display:inline; +width:auto; +margin:0; +padding:0; +border:0; +background:none; +vertical-align:center; +*vertical-align: top; +} + +input.radio, +input[type="radio"]{ +display:inline; +width:auto; +margin:0; +padding:0; +border:0; +background:none; +vertical-align:center; +*vertical-align: top; +} + + input[type="radio"]:focus, + input[ type="checkbox"]:focus{ + -webkit-box-shadow: 0 0 5px #6DB9FF; + -moz-box-shadow : 0 0 5px #6DB9FF; + box-shadow : 0 0 5px #6DB9FF; + outline-color: #6DB9FF; + } + +input.file, +input[type="file"]{ +/*font-size:0.8em;*/ +-moz-box-shadow:none; +-webkit-box-shadow:none; +box-shadow:none; +border:none; +} + +select{ +display:inline; +width:auto; +margin:0; +border:1px solid #ccc; +line-height:100%; +padding:3px; +vertical-align: middle; +} + + select[disabled="disabled"], select.disabled{ + color:#999; + background:#f5f5f5; + -moz-box-shadow:inset 0 0 2px #ddd; + -webkit-box-shadow:inset 0 1px 2px #ddd; + box-shadow:inset 0 1px 2px #ddd; + } + +textarea{ +width:auto; +height:200px; +margin:0; +border:1px solid #ccc; +padding:5px; +vertical-align: middle; +font-family:inherit; +font-size:0.9em; +-moz-border-radius:5px; +-webkit-border-radius:5px; +border-radius:5px; +-moz-box-shadow:inset 0 0 6px #ccc; +-webkit-box-shadow:inset 0 1px 6px #ccc; +box-shadow:inset 0 1px 6px #ccc; +-moz-box-sizing: border-box; +-webkit-box-sizing: border-box; +box-sizing: border-box; +} + +/*--------------------------------- + COLUMN SIZES +-----------------------------------*/ + +/* sizes */ +input[class*="col_"], +select[class*="col_"], +label[class*="col_"]{ +float:none;display:inline-block;*display:inline;margin-bottom:0; +*margin-left: 0.5%;*margin-right: 0.5%;/* this is for IE 7 Only and is not a good fix - work needed here */ +} + +/*--------------------------------- + FORMS VERTICAL +-----------------------------------*/ +form.vertical{ + +} + + form.vertical label{display:block;} + form.vertical input, + form.vertical select, + form.vertical textarea{width:100%;display:block;margin-bottom:10px;} + form.vertical .chzn-container{display:block;margin-bottom:10px;} + form.vertical .chzn-choices{display:block;margin-bottom:10px;} + + /* radios & checks */ + form.vertical input.checkbox, + form.vertical input[type="checkbox"], + form.vertical input.radio, + form.vertical input[type="radio"], + form.vertical label.inline{display:inline;width:auto;margin:0;} +/*--------------------------------- + FORM VALIDATION +-----------------------------------*/ +label.error{color:red;} +input.error{border:1px solid red;} +select.error{border:1px solid red;} + +/*--------------------------------- + NOTICES +-----------------------------------*/ +.notice{ +border:1px solid gold; +background:lightyellow; +padding:10px 20px 10px 40px; +margin:10px 0; +-moz-border-radius:5px; +-webkit-border-radius:5px; +border-radius:5px; +color:#DEAE00; +line-height:120%; +vertical-align: center; +text-shadow:0px 1px rgba(255,255,255,0.5); +position:relative; +top:0; +left:0; +clear:both; +} + + .notice.warning{}/*default*/ + .notice.error{border:1px solid red;background:pink;color:red;} + .notice.success{border:1px solid green;background:lightgreen;color:green;} + .notice i[class*='fa-']{position:absolute;top:50%;left:0.8em;margin-top:-0.6em;} + .notice a[class*='fa-remove'], + .notice a[class*='fa-remove']:active, + .notice a[class*='fa-remove']:visited{text-decoration:none;font-size:12px;position:absolute;top:5px;right:5px;left:auto;color:inherit;margin-top:0;left:auto;} ADDED cgisetup/www/css/kickstart-grid.css Index: cgisetup/www/css/kickstart-grid.css ================================================================== --- /dev/null +++ cgisetup/www/css/kickstart-grid.css @@ -0,0 +1,167 @@ +/* + 99Lime.com HTML KickStart by Joshua Gatcke + kickstart-grids.css + + DO NOT EDIT THIS FILE unless you know what you are doing. +*/ +/*--------------------------------- + GRID/COLUMNS +----------------------------------- + tinyfluidgrid.com + & girlfriendnyc.com + with changes by 99Lime +-----------------------------------*/ + /* + & Columns : 12 + & Gutter %: 20% + & MaxWidth: 1280px + */ + +.grid{ +max-width:1220px; +margin:0 auto; +padding:0 2em; +} + +.grid.flex{ +width:100%; +max-width:100%; +padding:0 2%; +padding:2em; +} + +.row{ +display:block; +overflow:hidden; +clear:both; +} + +*[class*="col_"].alpha{margin-left:0;} +*[class*="col_"].omega{margin-right:0;} + +.col_1 { width: 6.6666666666667%; } +.col_2 { width: 15%; } +.col_3 { width: 23.333333333333%; } +.col_4 { width: 31.666666666667%; } +.col_5 { width: 40%; } +.col_6 { width: 48.333333333333%; } +.col_7 { width: 56.666666666667%; } +.col_8 { width: 65%; } +.col_9 { width: 73.333333333333%; } +.col_10 { width: 81.666666666667%; } +.col_11 { width: 90%; } +.col_12 { width: 98.333333333333%; } + +*[class*="col_"]{ +margin-left: 0.83333333333333%; +margin-right: 0.83333333333333%; +margin-top:0.5em; +margin-bottom:0.5em; +float: left; +display: block; +} + +.grid img{ +max-width: 100%; +height:auto; +} + +.clear{clear:both;display:block;overflow:hidden;visibility:hidden;width:0;height:0} +.clearfix:after{clear:both;content:' ';display:block;font-size:0;line-height:0;visibility:hidden;width:0;height:0} +* html .clearfix, *:first-child+html .clearfix{zoom:1} + +/* Viewable Grids + To view your grids, add the class .visible to any grid container. + This will add a background color so you can see the layout of your grids. +*/ +*[class*="col_"].visible{ +background:#eee; +border:1px dotted #ccc; +} + + +/*--------------------------------- + Responsive Grid Media Queries - 1280, 1024, 768, 480 + 1280-1024 - desktop (default grid) + 1024-768 - tablet landscape + 768-480 - tablet + 480-less - phone landscape & smaller +-----------------------------------*/ +@media all and (min-width: 1024px) and (max-width: 1280px) { + + .grid *[class*="col_"]{} + .grid{max-width: 1024px;} + .show-desktop {display:block;} + .hide-desktop {display:none;} + .show-tablet {display:none;} + .hide-tablet {display:block;} + .show-phone {display:none;} + .hide-phone {display:block;} + +} + +@media all and (min-width: 768px) and (max-width: 1024px) { + + .grid *[class*="col_"]{} + .grid{max-width: 768px;} + .show-desktop {display:none;} + .hide-desktop {display:block;} + .show-tablet {display:block;} + .hide-tablet {display:none;} + .show-phone {display:none;} + .hide-phone {display:block;} + +} + + +@media all and (min-width: 480px) and (max-width: 768px) { + + .grid *[class*="col_"]{ + float:none; + width:auto; + clear:both; + display:block; + } + + /* columns inside of columns */ + .grid *[class*="col_"] [class*="col_"]{ + margin-left:0; + margin-right:0; + width:100%; + } + + .grid{max-width: 480px;} + .show-desktop {display:none;} + .hide-desktop {display:block;} + .show-tablet {display:block;} + .hide-tablet {display:none;} + .show-phone {display:none;} + .hide-phone {display:block;} + +} + +@media all and (max-width: 480px) { + + .grid *[class*="col_"]{ + float:none; + width:auto; + clear:both; + display:block; + } + + /* columns inside of columns */ + .grid *[class*="col_"] [class*="col_"]{ + margin-left:0; + margin-right:0; + width:100%; + } + + .grid{max-width: 100%;/*320*/} + .show-desktop {display:none;} + .hide-desktop {display:block;} + .show-tablet {display:none;} + .hide-tablet {display:block;} + .show-phone {display:block;} + .hide-phone {display:none;} + +} ADDED cgisetup/www/css/kickstart-menus.css Index: cgisetup/www/css/kickstart-menus.css ================================================================== --- /dev/null +++ cgisetup/www/css/kickstart-menus.css @@ -0,0 +1,180 @@ +/* + 99Lime.com HTML KickStart by Joshua Gatcke + kickstart-menus.css +*/ + +/*--------------------------------- + MENU LAYOUT + DO NOT EDIT This Section (unless you know what you are doing) +-----------------------------------*/ +.menu{margin:0;padding:0;line-height:100%; +font-size:0; /* Kill white space gap between LI elements */ +position:relative;z-index:1000;} + + .menu:after{clear:both;content:' ';display:block;font-size:0;line-height:0;visibility:hidden;width:0;height:0} + .menu li{margin:0;padding:0;list-style-type:none;display:inline-block;*display:inline;position:relative;zoom:1;line-height:inherit; + top:0;left:0;font-size:16px; /* fixed font-size to replace font-size:0 in parent .menu 1em/16px default */} + .menu li a{margin:0;padding:0;display:block;display:inline;display:inline-block;position:relative;zoom:1;line-height:100%;top:0;left:0;} + + +/*--------------Sub Menus-------------------*/ + /*.menu li:hover > ul{display:block;}*/ + .menu ul{margin:0;padding:0;position: absolute;top:100%;left:0;display:none;min-width:150px;max-width:150%;*width:150px;} + .menu ul li{display:block;width:100%;} + .menu ul li a{display:block;} + .menu ul ul{top:0;left:100%;} + +/*--------------Dividers-------------------*/ + .menu ul li.divider{border-top:1px solid #ccc;} + .menu ul li.divider a{border-top:1px solid #fff;} + + +/*--------------Right---------------------*/ + .menu li.right{float:right;} + + +/*--------------Arrows-------------------*/ + .menu li.has-menu a{padding-right:25px;} + .menu li.has-menu span.arrow{border-style:solid;border-width:5px; + display:block;position:absolute;top:50%;right:5px;font-size:0;line-height:0;height:0;width:0;} + .menu li li.has-menu span.arrow{margin-top:-4px;} + +/*--------------Vertical Menu Layout-------------------*/ +.menu.vertical{} + .menu.vertical li{display:block;} + .menu.vertical li a{display:block;} + .menu.vertical ul{top:0;left:100%;} + .menu.vertical li.has-menu span.arrow{margin-top:-4px;} + +/*--------------Vertical Right Menu Layout-------------------*/ +.menu.vertical.right{text-align:left;} + .menu.vertical.right ul{top:0;right:100%;left:auto;} + .menu.vertical.right li a{padding-left:25px;padding-right:20px;} + .menu.vertical.right li.has-menu span.arrow{right:auto;left:5px;margin-top:-4px;} + + +/*--------------------------------- + MENU STYLES + EDIT BELOW THIS LINE TO CUSTOMIZE +-----------------------------------*/ +.menu{ +border:1px solid #ccc; +background: #eee; /* Old browsers */ +background: -moz-linear-gradient(top, rgba(252,252,252,1) 0%, rgba(224,224,224,1) 100%); /* FF3.6+ */ +background: -webkit-gradient(linear, left top, left bottom, color-stop(0%,rgba(252,252,252,1)), color-stop(100%,rgba(224,224,224,1))); /* Chrome,Safari4+ */ +background: -webkit-linear-gradient(top, rgba(252,252,252,1) 0%,rgba(224,224,224,1) 100%); /* Chrome10+,Safari5.1+ */ +background: -o-linear-gradient(top, rgba(252,252,252,1) 0%,rgba(224,224,224,1) 100%); /* Opera11.10+ */ +background: linear-gradient(top, rgba(252,252,252,1) 0%,rgba(224,224,224,1) 100%); /* W3C */ +z-index:600; +} + + .menu li{} + + .menu li a{ + text-shadow:0px 1px 1px #fff; + padding:15px 20px; + text-decoration:none; + font-size:0.9em; + color: #777; + } + + .menu li.current>a, + .menu li.current>a:hover, + .menu li.current.hover>a{ + background: rgb(122,188,255); /* Old browsers */ + background: -moz-linear-gradient(top, rgba(122,188,255,1) 0%, rgba(96,171,248,1) 44%, rgba(64,150,238,1) 100%); /* FF3.6+ */ + background: -webkit-gradient(linear, left top, left bottom, color-stop(0%,rgba(122,188,255,1)), color-stop(44%,rgba(96,171,248,1)), color-stop(100%,rgba(64,150,238,1))); /* Chrome,Safari4+ */ + background: -webkit-linear-gradient(top, rgba(122,188,255,1) 0%,rgba(96,171,248,1) 44%,rgba(64,150,238,1) 100%); /* Chrome10+,Safari5.1+ */ + background: -o-linear-gradient(top, rgba(122,188,255,1) 0%,rgba(96,171,248,1) 44%,rgba(64,150,238,1) 100%); /* Opera11.10+ */ + filter: progid:DXImageTransform.Microsoft.gradient( startColorstr='#7abcff', endColorstr='#4096ee',GradientType=0 ); /* IE6-9 */ + background: linear-gradient(top, rgba(122,188,255,1) 0%,rgba(96,171,248,1) 44%,rgba(64,150,238,1) 100%); /* W3C */ + color:#fff; + text-shadow:0px -1px 0 rgba(0,0,0,0.2); + cursor: default; + } + + .menu li a:hover, + .menu li.hover>a{ + background:#f5f5f5; + } + + /* sub menus */ + .menu ul{ + background: #efefef; + border:1px solid #ccc; + } + + .menu ul li{} + .menu ul li a{} + + /* sub-sub menus */ + .menu ul ul{} + .menu ul ul li{} + .menu ul ul li a{} + + /* arrows */ + /* arrow down */ .menu li.has-menu span.arrow{border-color-top:#ccc;border-color:#ccc transparent transparent transparent;} + /* arrow left */ .menu li li.has-menu span.arrow, .menu.vertical li.has-menu span.arrow + {border-color-left:#ccc;border-color:transparent transparent transparent #ccc;} + /* arrow right */ .menu.vertical.right li.has-menu span.arrow{border-color-right:#ccc;border-color:transparent #ccc transparent transparent;} + + /* dividers */ .menu ul li.divider{border-top:1px solid #ccc;} + .menu ul li.divider a{border-top:1px solid #fff;} + + + +/*--------------------------------- + RESPONSIVE MENU STYLES + DO NOT EDIT unless you know what you are doing +-----------------------------------*/ + +.menu li.menu-toggle{display:none;} + + +@media all and (max-width: 768px) { + + .grid .menu li, + .grid .menu.vertical li, + .grid .menu.vertical.right li{ + display:block; + display:none; + } + + .grid .menu li.menu-toggle, + .grid .menu.vertical li.menu-toggle, + .grid .menu.vertical.right li.menu-toggle{ + display:block; + } + + .grid .menu:hover li, + .grid .menu.vertical:hover li, + .grid .menu.vertical.right:hover li{ + display:block; + } + + /* arrows */ + .grid .menu li.has-menu span.arrow, + .grid .menu.vertical li.has-menu span.arrow, + .grid .menu.vertical.right li.has-menu span.arrow, + .grid .menu li li.has-menu span.arrow, .menu.vertical li.has-menu span.arrow + {border-color-top:#ccc;border-color:#ccc transparent transparent transparent;} + + .grid .menu.vertical.right li.has-menu span.arrow{ + right:5px;left:auto; + } + + .grid .menu li a{ + display:block; + } + + .grid .menu ul, + .grid .menu ul ul, + .grid .menu.vertical ul, + .grid .menu.vertical.right ul{ + position:relative; + top:0; + left:0; + margin:10px; + } + +} ADDED cgisetup/www/css/kickstart-slideshow.css Index: cgisetup/www/css/kickstart-slideshow.css ================================================================== --- /dev/null +++ cgisetup/www/css/kickstart-slideshow.css @@ -0,0 +1,223 @@ +/*--------------------------------- + SLIDESHOW2 - Slight Fixes for the slideshow layout *needs work +-----------------------------------*/ + + .slideshow{ + clear:both; + margin:0; + padding:0; + width:auto; + height:auto; + overflow:hidden; + } + + .slideshow li{ + list-style-type:none; + margin:0; + padding:0; + float:left; + display:block; + } + +/** + * BxSlider v4.0 - Fully loaded, responsive content slider + * http://bxslider.com + * + * Written by: Steven Wanderski, 2012 + * http://stevenwanderski.com + * (while drinking Belgian ales and listening to jazz) + * + * CEO and founder of bxCreative, LTD + * http://bxcreative.com + */ + + +/** RESET AND LAYOUT +===================================*/ +.bx-wrapper, .bx-wrapper *{ + -webkit-box-sizing: content-box; /* Safari/Chrome, other WebKit */ + -moz-box-sizing: content-box; /* Firefox, other Gecko */ + box-sizing: content-box; /* Opera/IE 8+ */ +} + +.bx-wrapper { + position: relative; + margin: 0 0 60px; + padding: 0; + *zoom: 1; +} + +.bx-wrapper img { + width: 100%; + display: block; +} + +/** THEME +===================================*/ + +.bx-wrapper .bx-viewport { + -moz-box-shadow: 0 0 5px #ccc; + -webkit-box-shadow: 0 0 5px #ccc; + box-shadow: 0 0 5px #ccc; + border: solid #fff 5px; + left: 0; + background: #fff; +} + +.bx-wrapper .bx-pager, +.bx-wrapper .bx-controls-auto { + position: absolute; + bottom: -30px; + width: 100%; +} + +/* LOADER */ + +.bx-wrapper .bx-loading { + min-height: 50px; + background: url(img/bx_loader.gif) center center no-repeat #fff; + height: 100%; + width: 100%; + position: absolute; + top: 0; + left: 0; + z-index: 2000; +} + +/* PAGER */ + +.bx-wrapper .bx-pager { + text-align: center; + font-size: .85em; + font-family: Arial; + font-weight: bold; + color: #666; + padding-top: 20px; +} + +.bx-wrapper .bx-pager .bx-pager-item, +.bx-wrapper .bx-controls-auto .bx-controls-auto-item { + display: inline-block; + *zoom: 1; + *display: inline; +} + +.bx-wrapper .bx-pager.bx-default-pager a { + background: #666; + text-indent: -9999px; + display: block; + width: 10px; + height: 10px; + margin: 0 5px; + outline: 0; + -moz-border-radius: 5px; + -webkit-border-radius: 5px; + border-radius: 5px; +} + +.bx-wrapper .bx-pager.bx-default-pager a:hover, +.bx-wrapper .bx-pager.bx-default-pager a.active { + background: #000; +} + +/* DIRECTION CONTROLS (NEXT / PREV) */ + +.bx-wrapper .bx-prev { + left: 10px; + background: url(img/controls.png) no-repeat 0 -32px; +} + +.bx-wrapper .bx-next { + right: 10px; + background: url(img/controls.png) no-repeat -43px -32px; +} + +.bx-wrapper .bx-prev:hover { + background-position: 0 0; +} + +.bx-wrapper .bx-next:hover { + background-position: -43px 0; +} + +.bx-wrapper .bx-controls-direction a { + position: absolute; + top: 50%; + margin-top: -16px; + outline: 0; + width: 32px; + height: 32px; + text-indent: -9999px; + z-index: 9999; +} + +.bx-wrapper .bx-controls-direction a.disabled { + display: none; +} + +/* AUTO CONTROLS (START / STOP) */ + +.bx-wrapper .bx-controls-auto { + text-align: center; +} + +.bx-wrapper .bx-controls-auto .bx-start { + display: block; + text-indent: -9999px; + width: 10px; + height: 11px; + outline: 0; + background: url(img/controls.png) -86px -11px no-repeat; + margin: 0 3px; +} + +.bx-wrapper .bx-controls-auto .bx-start:hover, +.bx-wrapper .bx-controls-auto .bx-start.active { + background-position: -86px 0; +} + +.bx-wrapper .bx-controls-auto .bx-stop { + display: block; + text-indent: -9999px; + width: 9px; + height: 11px; + outline: 0; + background: url(img/controls.png) -86px -44px no-repeat; + margin: 0 3px; +} + +.bx-wrapper .bx-controls-auto .bx-stop:hover, +.bx-wrapper .bx-controls-auto .bx-stop.active { + background-position: -86px -33px; +} + +/* PAGER WITH AUTO-CONTROLS HYBRID LAYOUT */ + +.bx-wrapper .bx-controls.bx-has-controls-auto.bx-has-pager .bx-pager { + text-align: left; + width: 80%; +} + +.bx-wrapper .bx-controls.bx-has-controls-auto.bx-has-pager .bx-controls-auto { + right: 0; + width: 35px; +} + +/* IMAGE CAPTIONS */ + +.bx-wrapper .bx-caption { + position: absolute; + bottom: 0; + left: 0; + background: #666\9; + background: rgba(80, 80, 80, 0.75); + width: 100%; +} + +.bx-wrapper .bx-caption span { + color: #fff; + font-family: Arial; + display: block; + font-size: .85em; + padding: 10px; +} ADDED cgisetup/www/css/kickstart.css Index: cgisetup/www/css/kickstart.css ================================================================== --- /dev/null +++ cgisetup/www/css/kickstart.css @@ -0,0 +1,519 @@ +/* + 99Lime.com HTML KickStart by Joshua Gatcke + kickstart.css + + Don't edit the file if you want HTML KickStart to be upgradeable. + Instead, copy any CSS selectors you want to modify to your style.css file. + + // Colors + blue: #4D99E0; +*/ +/*--------------------------------- + IMPORTS +-----------------------------------*/ +@import url(kickstart-buttons.css); +@import url(kickstart-forms.css); +@import url(kickstart-menus.css); +@import url(kickstart-grid.css); +@import url(jquery.fancybox-1.3.4.css); +@import url(kickstart-slideshow.css); +@import url(prettify.css); +@import url(tiptip.css); +@import url(fonts/font-awesome-4.2.0/css/font-awesome.min.css); + +/*--------------------------------- + HTML ELEMENTS +-----------------------------------*/ +*{ +-webkit-box-sizing: border-box; /* Safari/Chrome, other WebKit */ +-moz-box-sizing: border-box; /* Firefox, other Gecko */ +box-sizing: border-box; /* Opera/IE 8+ */ +} +a{color:#4D99E0;outline:0;} +a:active{color:inherit;} +a:visited{} +a:hover{} +a img{border:0;} +a [class^="icon-"]{color:inherit;text-decoration:none;} +strong,b{color:#000;font-weight:bold;} +strike{} +em,i{} +.hide{display:none;} +.show{display:block;} + +/*--------------------------------- + UTILITY +-----------------------------------*/ +.center{text-align:center;} +.left{text-align:left;} +.right{text-align:right;} + +/*--------------------------------- + HR +-----------------------------------*/ +hr{clear:both;border-bottom:0;border-top:1px dotted #ccc;border-right:0;border-left:0;margin:30px 0;min-height: 0;height:1px;} +hr.alt1{border-style: solid;} +hr.alt2{border-style: dashed;} + +/*--------------------------------- + HTML5 ELEMENTS (shim) +-----------------------------------*/ +article,aside,details,figcaption,figure, +footer,header,hgroup,menu,nav,section { +display:block; +} + +/*--------------------------------- + HEADINGS +-----------------------------------*/ +h1,h2,h3,h4,h5,h6{ +font-weight:bold; +line-height:140%; +} + +h1{ +font-size:3.5em; +margin:10px 0 10px 0; +} + +h2{ +font-size:3em; +margin:10px 0 10px 0; +} + +h3{ +font-size:2.5em; +margin:10px 0 10px 0; +line-height:130%; +} + +h4{ +font-size:2em; +margin:10px 0 10px 0; +} + +h5{ +font-size:1.5em; +margin:10px 0 10px 0; +} + +h6{ +font-size:1.2em; +margin:10px 0 5px 0; +} + +/*--------------------------------- + PARAGRAPHS +-----------------------------------*/ +p{ +margin:10px 0; +} + +/*--------------------------------- + BLOCKQUOTES +-----------------------------------*/ +blockquote{ +font-size:1.5em; +line-height:1.5em; +font-style: italic; +margin:30px 30px 30px 0; +padding:0 0 0 20px; +border-left:1px solid #ccc; +} + + blockquote span{font-size:0.7em;display:block;} + blockquote.small{font-size:1.2em;} + +/*--------------------------------- + LISTS +-----------------------------------*/ +ul, ol{ +padding:0; +margin:0 0 20px 25px; +} + +li{ +padding:5px 0; +margin:0; +} + +ul.list-unstyled{ +padding:0; +margin:0 0 20px 0; +} + +ul.list-unstyled li{ +padding:5px 0; +margin:0; +list-style-type:none; + +} + +ul.alt{ +padding:0; +margin:0 0 20px 0; +} + +ul.alt li{ +list-style-type:none; +border-top:1px dotted #ccc; +border-bottom:1px dotted #ccc; +margin:0 0 -1px 0; +background:url(img/icon-arrow-right.png) no-repeat 5px 0.7em; +padding-left:20px; +} + +ul.icons{ +margin:0 0 20px 0; +padding:0; +} + +ul.icons li{ +list-style-type:none; +margin:0; +padding:5px 0; +} + +/*--------------------------------- + PRE & CODE +-----------------------------------*/ +code{ +font-family: Consolas, "Andale Mono WT", "Andale Mono", "Lucida Console", "Lucida Sans Typewriter", "DejaVu Sans Mono", "Bitstream Vera Sans Mono", "Liberation Mono", "Nimbus Mono L", Monaco, "Courier New", Courier, monospace; +font-size:0.9em; +border:1px solid lightblue; +padding:3px; +-moz-border-radius:3px; +-webkit-border-radius:3px; +border-radius:3px; +color:#518BAB; +} + +pre{ +white-space: pre-wrap; /* css-3 */ +white-space: -moz-pre-wrap !important; /* Mozilla, since 1999 */ +white-space: -pre-wrap; /* Opera 4-6 */ +white-space: -o-pre-wrap; /* Opera 7 */ +word-wrap: break-word; /* Internet Explorer 5.5+ */ +margin: 0 0 0 0; +padding:5px 5px 3px 5px; +background:#fff; +-moz-border-radius:5px; +-webkit-border-radius:5px; +border-radius:5px; +-webkit-box-shadow:inset 0 0 7px rgba(0,0,0,0.2); +-moz-box-shadow:inset 0 0 7px rgba(0,0,0,0.2); +box-shadow:inset 0 0 7px rgba(0,0,0,0.2); +padding:10px; +margin:0 0; +border:1px solid #ddd; +font-family: Consolas, "Andale Mono WT", "Andale Mono", "Lucida Console", "Lucida Sans Typewriter", "DejaVu Sans Mono", "Bitstream Vera Sans Mono", "Liberation Mono", "Nimbus Mono L", Monaco, "Courier New", Courier, monospace; +font-size:0.9em; +} + +/*--------------------------------- + TABLES +-----------------------------------*/ +table{width:100%;margin:0 0 10px 0;text-align:left;border-collapse: collapse;} + thead, tbody{margin:0;padding:0;} + th, td{padding:7px 10px;font-size:0.9em;border-bottom:1px dotted #ddd;text-align:left;} + thead th{font-size:0.9em;padding:3px 10px;border-bottom:1px solid #ddd;} + tbody tr.last th, + tbody tr.last td{border-bottom:0;} + +/* striped */ +table.striped{} + table.striped tr.alt{background:#f5f5f5;} + table.striped thead th{background:#fff;} + table.striped tbody th{background:#f5f5f5;text-align:right;padding-right:15px;border-right:1px dotted #e5e5e5;} + table.striped tbody tr.alt th{background:#efefef;} + +/* tight */ +table.tight{} + table.tight th, .tight td{padding:2px 10px;} + +/* sortable */ +table.sortable{border:1px solid #ddd;} + table.sortable thead th{cursor: pointer;position:relative;top:0;left:0;border-right:1px solid #ddd;} + table.sortable thead th:hover{background:#efefef;} + table.sortable span.arrow{border-style:solid;border-width:5px; + display:block;position:absolute;top:50%;right:5px;font-size:0; + border-color:#ccc transparent transparent transparent; + line-height:0;height:0;width:0;margin-top:-2px;} + table.sortable span.arrow.up{border-color:transparent transparent #ccc transparent;margin-top:-7px;} + +/*--------------------------------- + TABS +-----------------------------------*/ +ul.tabs{ +margin:10px 0 -1px 0; +padding:0; +width:100%; +border-bottom:1px solid #e5e5e5; +float:left; +font-size:0; +} + + ul.tabs.left{text-align:left;} + ul.tabs.center{text-align:center;} + ul.tabs.right{text-align:right;} + ul.tabs.right li{margin:0 0 0 -2px;} + + ul.tabs li{ + font-size:14px; + list-style-type:none; + margin:0 -2px 0 0; + padding:0; + display:inline-block; + *display:inline;/*IE ONLY*/ + position:relative; + top:0; + left:0; + *top:1px;/*IE 7 ONLY*/ + zoom:1; + } + + ul.tabs li a{ + text-decoration:none; + color:#666; + display:inline-block; + padding:9px 15px; + position: relative; + top:0; + left:0; + line-height:100%; + background:#f5f5f5; + -webkit-box-shadow: inset 0 -3px 3px rgba(0,0,0,0.03); + -moz-box-shadow: inset 0 -3px 3px rgba(0,0,0,0.03); + box-shadow: inset 0 -3px 3px rgba(0,0,0,0.03); + border:1px solid #e5e5e5; + border-bottom:0; + font-size:0.9em; + zoom:1; + } + + ul.tabs li a:hover{ + background:#fff; + } + + ul.tabs li.current a{ + position:relative; + top:1px; + left:0; + background:#fff; + -webkit-box-shadow: none; + -moz-box-shadow: none; + box-shadow: none; + color:#222; + } + + .tab-content{ + border:1px solid #efefef; + border:1px solid #e5e5e5; + background:#fff; + clear:both; + padding:20px; + margin:0 0 40px 0; + } + + +/*--------------------------------- + BREADCRUMBS +-----------------------------------*/ +ul.breadcrumbs{ +margin:10px 0; +padding:0; +line-height:0%; +font-size:0; +} + + ul.breadcrumbs li{ + list-style-type:none; + margin:0; + padding:0; + display:inline-block; + *display:inline; /* IE ONLY*/ + position:relative; + zoom:1; + line-height:100%; + font-size:14px; /* 0.8em default to override font-size:0; on parent*/ + } + + ul.breadcrumbs li a{ + display:inline-block; + *display:inline; /* IE ONLY*/ + position:relative; + padding:5px 15px 5px 5px; + font-size:0.9em; + zoom:1; + margin:0; + background:url(img/icon-arrow-right.png) no-repeat right center; + } + + ul.breadcrumbs li.last a{ + color:#333; + cursor: default; + text-decoration:none; + background:none; + } + + ul.breadcrumbs li.last a:hover{ + text-decoration:none; + } + + /* Alternative Style */ + ul.breadcrumbs.alt1{ + border:1px solid transparent; + font-size:0; + } + + ul.breadcrumbs.alt1 li a{ + padding:10px 25px 10px 15px; + background:url(img/breadcrumbs-bg.gif) no-repeat right center; + text-decoration:none; + border-top:1px solid #efefef; + border-bottom:1px solid #efefef; + font-size:12px; + } + + ul.breadcrumbs.alt1 a:hover{ + text-decoration:underline; + } + + ul.breadcrumbs.alt1 li.first a{ + border-left:1px solid #efefef; + } + + ul.breadcrumbs.alt1 li.last a{ + background:none; + border-right:1px solid #efefef; + } + +/*--------------------------------- + IMAGES +-----------------------------------*/ +/* + for img .style1, .style2, .style3 + view js/kickstart.js Image Style Helpers +*/ +img{ +margin:0; +padding:0; +display:inline-block; +position:relative; +zoom:1; +vertical-align: bottom; +} + + img.align-left, .img-wrap.align-left{float:left;margin:0 10px 5px 0;} + img.align-right, .img-wrap.align-right{float:right;margin:0 0 5px 10px;} + img.full-width{clear:both;display:block;width:100%;height:auto;margin:0 0 10px 0;} + + div.caption{ + background:#f5f5f5; + border:1px solid #ddd; + padding:3px; + max-width:100%; + display:inline-block; + height:auto; + } + + div.caption img{ + display:block; + padding:0; + margin:0; + width:100%; + height:auto; + } + + div.caption span{ + display:block; + margin-top:3px; + font-size:0.8em; + color:#666; + padding:0px 5px; + } + + .gallery{} + + .gallery a{ + display:inline-block; + position:relative; + border:1px solid #ddd; + background:#fff; + padding:3px; + margin:5px; + -moz-border-radius:5px; + -webkit-border-radius:5px; + border-radius:5px; + } + + .gallery a img{ + display: block; + position: relative; + margin:0; + padding:0; + } + +/*--------------------------------- + SLIDESHOW2 +-----------------------------------*/ +.slideshow-wrap{ +clear:both; +margin:0; +padding:0; +position:relative; +top:0; +left:0; +overflow:hidden; +clear:both; +} + + .slideshow-inner{ + overflow:hidden; + clear:both; + position:relative; + top:0; + left:0; + border:1px solid #efefef; + } + + .slideshow{ + clear:both; + margin:0; + padding:0; + width:auto; + height:auto; + overflow:hidden; + } + + .slideshow li{ + list-style-type:none; + margin:0; + padding:0; + float:left; + display:block; + } + + .slideshow img{vertical-align: bottom;} + + .slideshow-buttons{ + text-align:right; + margin:3px 0 0 0; + padding:0; + } + + .slideshow-buttons li{display:inline;position:relative;top:0;left:0;line-height:100%;margin:0;padding:0;} + .slideshow-buttons li.current a{background:#ddd;} + + .slideshow-buttons a{ + display:inline; + position:relative; + top:0; + left:0; + padding:1px 3px; + margin:0 1px; + line-height:100%; + border:1px solid #efefef; + text-decoration:none; + font-size:0.8em; + } ADDED cgisetup/www/css/prettify.css Index: cgisetup/www/css/prettify.css ================================================================== --- /dev/null +++ cgisetup/www/css/prettify.css @@ -0,0 +1,1 @@ +.pln{color:#000}@media screen{.str{color:#080}.kwd{color:#008}.com{color:#800}.typ{color:#606}.lit{color:#066}.pun,.opn,.clo{color:#660}.tag{color:#008}.atn{color:#606}.atv{color:#080}.dec,.var{color:#606}.fun{color:red}}@media print,projection{.str{color:#060}.kwd{color:#006;font-weight:bold}.com{color:#600;font-style:italic}.typ{color:#404;font-weight:bold}.lit{color:#044}.pun,.opn,.clo{color:#440}.tag{color:#006;font-weight:bold}.atn{color:#404}.atv{color:#060}}pre.prettyprint{}ol.linenums{margin-top:0;margin-bottom:0}li.L0,li.L1,li.L2,li.L3,li.L5,li.L6,li.L7,li.L8{list-style-type:none}li.L1,li.L3,li.L5,li.L7,li.L9{background:#eee} ADDED cgisetup/www/css/tiptip.css Index: cgisetup/www/css/tiptip.css ================================================================== --- /dev/null +++ cgisetup/www/css/tiptip.css @@ -0,0 +1,99 @@ +/* + TipTip CSS - Version 1.2 + http://code.drewwilson.com/entry/tiptip-jquery-plugin +*/ + +#tiptip_holder { display: none; position: absolute; top: 0; left: 0; z-index: 99999; } +#tiptip_holder.tip_top { padding-bottom: 5px; } +#tiptip_holder.tip_bottom { padding-top: 5px; } +#tiptip_holder.tip_right { padding-left: 5px; } +#tiptip_holder.tip_left { padding-right: 5px; } + +#tiptip_content { +font-size: 11px; +color: #fff; +text-shadow: 0 0 2px #000; +padding: 4px 8px; +border: 1px solid rgba(255,255,255,0.25); +background:#212121; +background-color: rgba(25,25,25,0.92); +background-image: -webkit-gradient(linear, 0% 0%, 0% 100%, from(transparent), to(#000)); +-webkit-border-radius: 3px; +-moz-border-radius: 3px; +border-radius: 3px; +-webkit-box-shadow: 0 0 3px #555; +-moz-box-shadow: 0 0 3px #555; +box-shadow: 0 0 3px #555; +*background:#212121; +} + +#tiptip_arrow, #tiptip_arrow_inner { +position: absolute; +border-color: transparent; +border-style: solid; +border-width: 6px; +height: 0; +width: 0; +} + +#tiptip_holder.tip_top #tiptip_arrow { +border-top-color: #fff; +border-top-color: rgba(255,255,255,0.35); +} + +#tiptip_holder.tip_bottom #tiptip_arrow { +border-bottom-color: #fff; +border-bottom-color: rgba(255,255,255,0.35); +} + +#tiptip_holder.tip_right #tiptip_arrow { +border-right-color: #fff; +border-right-color: rgba(255,255,255,0.35); +} + +#tiptip_holder.tip_left #tiptip_arrow { +border-left-color: #fff; +border-left-color: rgba(255,255,255,0.35); +} + +#tiptip_holder.tip_top #tiptip_arrow_inner { +margin-top: -7px; +margin-left: -6px; +border-top-color: rgb(25,25,25); +border-top-color: rgba(25,25,25,0.92); +} + +#tiptip_holder.tip_bottom #tiptip_arrow_inner { +margin-top: -5px; +margin-left: -6px; +border-bottom-color: rgb(25,25,25); +border-bottom-color: rgba(25,25,25,0.92); +} + +#tiptip_holder.tip_right #tiptip_arrow_inner { +margin-top: -6px; +margin-left: -5px; +border-right-color: rgb(25,25,25); +border-right-color: rgba(25,25,25,0.92); +} + +#tiptip_holder.tip_left #tiptip_arrow_inner { +margin-top: -6px; +margin-left: -7px; +border-left-color: rgb(25,25,25); +border-left-color: rgba(25,25,25,0.92); +} + +/* Webkit Hacks */ +@media screen and (-webkit-min-device-pixel-ratio:0) { + #tiptip_content { + padding: 4px 8px 5px 8px; + background-color: rgba(45,45,45,0.88); + } + #tiptip_holder.tip_bottom #tiptip_arrow_inner { + border-bottom-color: rgba(45,45,45,0.88); + } + #tiptip_holder.tip_top #tiptip_arrow_inner { + border-top-color: rgba(20,20,20,0.92); + } +} ADDED cgisetup/www/elements.html Index: cgisetup/www/elements.html ================================================================== --- /dev/null +++ cgisetup/www/elements.html @@ -0,0 +1,1816 @@ + + +HTML KickStart Elements + + + + + + + + + + + +

HTML KickStart

Ultra–Lean HTML5, CSS, & JS Building Blocks
for Rapid Website Production

+
+ Responsive +

+ +

+
+ MIT Open Source +

+ +

+
+ 479 Icons
+

+ +

+
+ Designer Friendly + +

+ Download (Github) + + +
+

Downloaded over 91036 Times :)

+ +

+ + +

Getting Started

Instructions

+ +

Setup

Download HTML KickStart

Include jQuery and HTML KickStart +

+<script src="https://ajax.googleapis.com/ajax/libs/jquery/1.9.1/jquery.min.js"></script>
+<script src="js/kickstart.js"></script> <!-- KICKSTART -->
+<link rel="stylesheet" href="css/kickstart.css" media="all" /> <!-- KICKSTART -->
+

Copy Elements into your HTML

Browsers

+ HTML KickStart Tested and working in IE 8+, Safari, Chrome, Firefox, Opera, Safari IOS, Browser and Chrome Android. +

Notes

+ Don't forget to use an HTML5 Doctype + <!DOCTYPE html> +

+ + + + +

Buttons

Example
Sizes
With Icons
Colors
Styles
Button Bar

+ + + +

Buttons

+
+ A.button
+
+
+
+ +

+ + +

With Icons

+
+
+
+

+ + +

Colors

+
+ .orange
+
+
+ +

+ + +

Styles

+
+
+ .pop
+
+ +

+ +

Button Bar

Edit
Tag
Upload

+ +

+<!-- Button Sizes -->
+<button>Button</button>
+<a class="button" href="">A.button</a>
+<button class="small">Small</button>
+<button class="small" disabled="disabled">Small (disabled)</button>
+<button class="medium">Medium</button>
+<button class="large">Large</button>

+ +

+<!-- Buttons w/Icons -->
+<button class="small"><i class="fa fa-picture-o"></i> Small</button>
+<button class="medium"><i class="fa fa-coffee"></i> Medium</button>
+<button class="large"><i class="fa fa-leaf"></i> Large</button>

+ +

+<!-- Buttons w/Colors -->
+<button class="blue"><i class="fa fa-star"></i> .blue</button>
+<a class="button orange" href=""><i class="fa fa-music"></i> .orange</a>
+<button class="small pink"><i class="fa fa-plus-square"></i> .pink</button>
+<button class="medium green"><i class="fa fa-play-circle"></i> .green</button>
+<button class="large red"><i class="fa fa-minus-square"></i> .red</button>

+ +

+<!-- Default (no style) -->
+<button>default</button>
+
+<!-- Pill -->
+<button class="pill"><i class="fa fa-star"></i> .pill</button>
+
+<!-- Pop -->
+<a class="button pop" href=""><i class="fa fa-music"></i> .pop</a>
+
+<!-- Inset -->
+<button class="inset"><i class="fa fa-plus-square"></i> .inset</button>
+
+<!-- Square -->
+<button class="square"><i class="icon-minus-square"></i> .square</button>
+

+ +

+<!-- Button Bar w/icons -->
+<ul class="button-bar">
+<li><a href=""><i class="fa fa-pencil"></i> Edit</a></li>
+<li><a href=""><i class="fa fa-tag"></i> Tag</a></li>
+<li><a href=""><i class="fa fa-upload"></i> Upload</a></li>
+<li><a href=""><i class="fa fa-plus-sign"></i></a></li>
+</ul>
+

+ + +

Lists

Example
UL
OL
UL.icons
UL.alt

+ +

Unordered List

Apple
Banana
Orange
Pear

+ +

Ordered List

Apple
Banana
Orange
Pear

+ +

UL.icons

Apple
Banana
Orange
Pear

+ +

UL.alt

Apple
Banana
Orange
Pear

+ +

+<!-- Unordered List -->
+<ul>
+<li>Apple</li>
+<li>Banana</li>
+<li>Orange</li>
+<li>Pear</li>
+</ul>

+ +

+<!-- Ordered List -->
+<ol>
+<li>Apple</li>
+<li>Banana</li>
+<li>Orange</li>
+<li>Pear</li>
+</ol>

+ +

+<!-- List Icons -->
+<ul class="icons">
+<li><i class="fa fa-check"></i>Apple</li>
+<li><i class="fa fa-check"></i>Banana</li>
+<li><i class="fa fa-check"></i>Orange</li>
+<li><i class="fa fa-remove"></i>Pear</li>
+</ul>

+ +

+<!-- List Alternative Style -->
+<ul class="alt">
+<li>Apple</li>
+<li>Banana</li>
+<li>Orange</li>
+<li>Pear</li>
+</ul>

+ + +

+ +

These Menus are optionally responsive when using a responsive grid: .grid or .grid.flex

+ +

Vertical Left

+ +

+ + +

Horizontal

+ +

+ + +

Vertical Right

+ +

+<!-- Menu Vertical Left -->
+<ul class="menu vertical">
+<li class="current"><a href="">Item 1</a></li>
+<li><a href="">Item 2</a></li>
+<li><a href="">Item 3</a>
+	<ul>
+	<li><a href="">Sub Item that is super long and we don't want it to break the menu</a></li>
+	<li><a href="">Sub Item</a>
+		<ul>
+		<li><a href="">Sub Item</a></li>
+		<li><a href="">Sub Item</a></li>
+		<li><a href="">Sub Item</a></li>
+		<li><a href="">Sub Item</a></li>
+		</ul>
+	</li>
+	<li><a href="">Sub Item</a></li>
+	</ul>
+</li>
+<li><a href="">Item 4</a></li>
+</ul>

+ +

+<!-- Menu Horizontal -->
+<ul class="menu">
+<li class="current"><a href="">Item 1</a></li>
+<li><a href="">Item 2</a></li>
+<li><a href=""><i class="fa fa-inbox"></i> Item 3</a>
+	<ul>
+	<li><a href=""><i class="fa fa-cog"></i> Sub Item</a></li>
+	<li><a href=""><i class="fa fa-envelope"></i> Sub Item</a>
+		<ul>
+		<li><a href=""><i class="fa fa-wrench"></i> Sub Item</a></li>
+		<li><a href=""><i class="fa fa-camera-retro"></i> Sub Item</a></li>
+		<li><a href=""><i class="fa fa-coffee"></i> Sub Item</a></li>
+		<li><a href=""><i class="fa fa-twitter"></i> Sub Item</a></li>
+		</ul>
+	</li>
+	<li class="divider"><a href=""><i class="fa fa-trash"></i> li.divider</a></li>
+	</ul>
+</li>
+<li><a href="">Item 4</a></li>
+</ul>

+ +

+<!-- Menu Vertical Right -->
+<ul class="menu vertical right">
+<li><a href="">Item 1</a></li>
+<li><a href="">Item 2</a></li>
+<li><a href="">Item 3</a>
+	<ul>
+	<li><a href="">Sub Item</a></li>
+	<li class="current"><a href="">Sub Item</a>
+		<ul>
+		<li><a href="">Sub Item</a></li>
+		<li><a href="">Sub Item</a></li>
+		<li><a href="">Sub Item</a></li>
+		<li><a href="">Sub Item</a></li>
+		</ul>
+	</li>
+	<li><a href="">Sub Item</a></li>
+	</ul>
+</li>
+<li><a href="">Item 4</a></li>
+</ul></pre>
+

+ + +

Tables

Example
Table
Table w/side TH
Table Styles

+ +

Table (default)

+ + + + + + + + + + + + + + + + + + + + + + + +

Item1	Item2	Item3
Item1	Item2	Item3
Item1	Item2	Item3
Item1	Item2	Item3
Item1	Item2	Item3

+ +

Table.striped

+ + + + + + + + + + + + + + + + + + + + + + + +

	Item2	Item3
Item1	Item2	Item3
Item1	Item2	Item3
Item1	Item2	Item3
Item1	Item2	Item3

+ +

Table.tight

+ + + + + + + + + + + + + + + + + + + + + + + +

Item1	Item2	Item3
Item1	Item2	Item3
Item1	Item2	Item3
Item1	Item2	Item3
Item1	Item2	Item3

+ +

Table.sortable

+ + + + + + + + + + + + + + + + + + + + + + + + + + + + +

Name	Number	Color	Actions
Joshua	555-4325	Blue	+
Peter	555-5698	Gold	+
Mary	666-7654	Red	+
Gretty	555-6732	Pink	+

+ +

+<!-- Table -->
+<table cellspacing="0" cellpadding="0">
+<thead><tr>
+	<th>Item1</th>
+	<th>Item2</th>
+	<th>Item3</th>
+</tr></thead>
+<tbody><tr>
+	<td>Item1</td>
+	<td>Item2</td>
+	<td>Item3</td>
+</tr><tr>
+	<td>Item1</td>
+	<td>Item2</td>
+	<td>Item3</td>
+</tr><tr>
+	<td>Item1</td>
+	<td>Item2</td>
+	<td>Item3</td>
+</tr><tr>
+	<td>Item1</td>
+	<td>Item2</td>
+	<td>Item3</td>
+</tr></tbody>
+</table>

+ +

+<!-- Table w/Side -->
+<table cellspacing="0" cellpadding="0">
+<thead><tr>
+	<th> </th>
+	<th>Item2</th>
+	<th>Item3</th>
+</tr></thead>
+<tbody><tr>
+	<th>Item1</th>
+	<td>Item2</td>
+	<td>Item3</td>
+</tr><tr>
+	<th>Item1</th>
+	<td>Item2</td>
+	<td>Item3</td>
+</tr><tr>
+	<th>Item1</th>
+	<td>Item2</td>
+	<td>Item3</td>
+</tr><tr>
+	<th>Item1</th>
+	<td>Item2</td>
+	<td>Item3</td>
+</tr></tbody>
+</table>

+ +

+<!-- Table striped -->
+<table class="striped">
+...
+</table>
+
+<!-- Table tight -->
+<table class="tight">
+...
+</table>
+
+<!-- Table sortable -->
+<table class="sortable">
+...
+</table>
+
+<!-- Table combined Styles -->
+<table class="striped tight sortable">
+...
+</table>
+

+ + +

ToolTips

Example
Positions
w/ HTML Content

+ + + +

+<!-- Tooltip Default (top) -->
+<span class="tooltip" title="This is a default (top) tooltip">.tooltip</span>
+
+<!-- Tooltip Top -->
+<span class="tooltip-top" title="This is a Top tooltip">.tooltip-top</span>
+
+<!-- Tooltip Right -->
+<span class="tooltip-right" title="This is a Right tooltip">.tooltip-right</span>
+
+<!-- Tooltip Left -->
+<span class="tooltip-left" title="This is a Left tooltip">.tooltip-left</span>
+
+<!-- Tooltip Bottom -->
+<span class="tooltip-bottom" title="This is a Bottom tooltip">.tooltip-bottom</span>
+

+ +

+<!-- Hover Action -->
+<button class="tooltip medium orange pill" data-content="#tooltipcontentID">Hover Over Me</button>
+
+<!-- Click Action -->
+<button class="tooltip medium blue pill" data-content="#tooltipcontentID" data-action="click">Click Me</button>
+
+<!-- Tooltip Content -->
+<div class="tooltip-content" id="tooltipcontentID"><h5>HTML Content</h5>
+<img src="http://placehold.it/180x150/4D99E0/ffffff.png&text=180x150" width="180" height="150" />
+<p>This is more HTML content. You can place any HTML in this tooltip.</p></div>
+

+ + + +

Typography

Example
Headings
Paragraphs
Blockquote
Blockquote.small
Inline Styles
Address

+ +

Paragraphs

Lorem ipsum dolor sit amet, consectetuer adipiscing elit, sed diam nonummy nibh euismod tincidunt ut laoreet dolore + magna aliquam erat volutpat. Ut wisi enim ad minim veniam, quis nostrud exerci tation ullamcorper + suscipit lobortis nisl ut aliquip ex ea commodo consequat. Duis autem vel eum iriure dolor in + hendrerit in vulputate velit esse molestie consequat

El illum dolore eu feugiat nulla facilisis at vero eros et accumsan et iusto odio dignissim + qui blandit praesent luptatum zzril delenit augue duis dolore te feugait nulla facilisi. Nam + liber tempor cum soluta nobis eleifend option congue nihil imperdiet doming id quod mazim + placerat facer possim assum.

+ + +

Blockquote

lobortis nisl ut aliquip ex ea commodo consequat. Duis autem vel eum iriure dolor in hendrerit + in vulputate velit esse molestie consequat, vel illum dolore eu feugiat nulla facilisis at vero eros et accumsan + et iusto odio + Someone Important

+ + +

Blockquote Small

lobortis nisl ut aliquip ex ea commodo consequat. Duis autem vel eum iriure dolor in hendrerit + in vulputate velit esse molestie consequat, vel illum dolore eu feugiat nulla facilisis at vero eros et accumsan + et iusto odio + Someone Important

+ + +

Inline Styles

Strong
Emphasis
Inline Link
~~Strike~~
Inline Icons
<h1>Sample Code</h1>

+ +

Heading 1

Heading 2

Heading 3

Heading 4

Heading 5

Heading 6

+ +

Address

+ 1234 South Creek Lane
+ Calgary, Alberta, Canada
+ T4B–1S6 +

+ +

+<!-- Headings 1–6 -->
+<h1>Heading 1</h1>
+<h2>Heading 2</h2>
+<h3>Heading 3</h3>
+<h4>Heading 4</h4>
+<h5>Heading 5</h5>
+<h6>Heading 6</h6>

+ +

+<!-- Paragraph -->
+<p>Consectetuer adipiscing elit, sed diam nonummy nibh euismod tincidunt...</p>
+<p>El illum dolore eu feugiat nulla facilisis at vero eros et accumsan...</p>

+ +

+<!-- Blockquote -->
+<blockquote>
+<p>
+lobortis nisl ut aliquip ex ea commodo consequat. Duis autem vel eum iriure dolor in hendrerit 
+in vulputate velit esse molestie consequat, vel illum dolore eu feugiat nulla facilisis at vero eros et accumsan 
+et iusto odio
+<span>Someone Important</span>
+</p>
+</blockquote>

+ +

+<!-- Blockquote Small -->
+<blockquote class="small">
+<p>
+lobortis nisl ut aliquip ex ea commodo consequat. Duis autem vel eum iriure dolor in hendrerit 
+in vulputate velit esse molestie consequat, vel illum dolore eu feugiat nulla facilisis at vero eros et accumsan 
+et iusto odio
+<span>Someone Important</span>
+</p>
+</blockquote>

+ +

<!-- Strong -->
+<strong>Strong</strong>
+
+<!-- Emphasis -->
+<em>Emphasis</em>
+
+<!-- Inline Link -->
+<a href="">Inline Link</a>
+
+<!-- Strike -->
+<strike>Strike</strike>
+
+<!--Inline Icons -->
+Inline <i class="icon-film"></i> Icons
+
+<!--Sample Code (encoded entities) -->
+<code>&lt;h1&gt;Sample Code&lt;/h1&gt;</code>

+ +

+<!-- Address -->
+<address><p>
+1234 South Creek Lane<br />
+Calgary, Alberta, Canada<br />
+T4B–1S6
+</p>
+</address>

+ + +

Horizontal Rules

Example
HTML

+ +

HR

+ +

HR.alt1

+ +

HR.alt2

+ +

+<!-- HR -->
+<hr />
+
+<!-- HR.alt1 -->
+<hr class="alt1" />
+
+<!-- HR.alt2 -->
+<hr class="alt2" />

+ + + + +

Icons/Glyphs

HTML KickStart now using
Font Awesome 4.2.0 Icons!

+ How to use icons: <i class="fa fa-globe"></i>. +
Replace fa-globe with the icon you would like to use from the Cheatsheet.

+ + + + +
+ To increase the size of icons relative to its container, use fa-large, fa-2x, fa-3x, or fa-4x.

+ .pull-left Lorem ipsum dolor sit amet, consectetur adipisicing elit, sed do eiusmod tempor incididunt ut labore et dolore magna aliqua. Ut enim ad minim veniam. Fugiat nulla pariatur. Excepteur sint occaecat cupidatat non proident, sunt in culpa qui officia deserunt mollit anim id est laborum. +

+ .pull-right Lorem ipsum dolor sit amet, consectetur adipisicing elit, sed do eiusmod tempor incididunt ut labore et dolore magna aliqua. Ut enim ad minim veniam. Fugiat nulla pariatur. Excepteur sint occaecat cupidatat non proident, sunt in culpa qui officia deserunt mollit anim id est laborum. +

+ .fa-border Lorem ipsum dolor sit amet, consectetur adipisicing elit, sed do eiusmod tempor incididunt ut labore et dolore magna aliqua. Ut enim ad minim veniam. Fugiat nulla pariatur. Excepteur sint occaecat cupidatat non proident, sunt in culpa qui officia deserunt mollit anim id est laborum. +

+ + +

Code/Pre

Example
PRE.html
PRE.css
PRE.js
PRE.php

+ +

+	
+	PRE HTML
+	+<html>
+<head><title>This is a title</title></head>
+<body class="subpage">
+	<!-- Content Here -->
+</body>
+</html>
+	

+	
+	
+	
+	PRE CSS
+	+body{
+font-weight:bold;
+color:#000;
+line-height:150%;
+}
+	

+	
+	
+	
+	PRE JS
+	+$(document).ready(function(){
+	alert('jQuery');
+});
+	

+	

+ +

+<!-- Code HTML -->
+<pre>
+…code goes here… 
+</pre>

+ +

+<!-- Code CSS -->
+<pre>
+…code goes here… 
+</pre>

+ +

+<!-- Code Javascript -->
+<pre>
+…code goes here… 
+</pre>

+ +

+<!-- Code PHP -->
+<pre>
+…code goes here… 
+</pre>

+ + +

Tabs

Example
Tabs.left
Tabs.center
Tabs.right

+ +

Tabs.left

Tab1
Tab2
Tab3

+ +

Tab1

Tab2

Tab3

+ + +

Tabs.center

Tab1
Tab2
Tab3

+ +

Tab1

Tab2 has an icon.

Tab3

+ + +

Tabs.right

Tab1
Tab2
Tab3

+ +

Tab1

Tab2

Tab3

+ +

+<!-- Tabs Left -->
+<ul class="tabs left">
+<li><a href="#tabr1">Tab1</a></li>
+<li><a href="#tabr2">Tab2</a></li>
+<li><a href="#tabr3">Tab3</a></li>
+</ul>
+
+<div id="tabr1" class="tab-content">Tab1</div>
+<div id="tabr2" class="tab-content">Tab2</div>
+<div id="tabr3" class="tab-content">Tab3</div>

+ +

+<!-- Tabs Center -->
+<ul class="tabs center">
+<li><a href="#tabc1">Tab1</a></li>
+<li><a href="#tabc2"><i class="fa fa-folder-open"></i> Tab2</a></li>
+<li><a href="#tabc3">Tab3</a></li>
+</ul>
+
+<div id="tabc1" class="tab-content">Tab1</div>
+<div id="tabc2" class="tab-content">Tab2 has an icon.</div>
+<div id="tabc3" class="tab-content">Tab3</div>

+ +

+<!-- Tabs Right -->
+<ul class="tabs right">
+<li><a href="#tabr1">Tab1</a></li>
+<li><a href="#tabr2">Tab2</a></li>
+<li><a href="#tabr3">Tab3</a></li>
+</ul>
+
+<div id="tabr1" class="tab-content">Tab1</div>
+<div id="tabr2" class="tab-content">Tab2</div>
+<div id="tabr3" class="tab-content">Tab3</div>

+ + +

Breadcrumbs

Example
Breadcrumbs
Breadcrumbs.alt1

+ +

Breadcrumbs

+ +

Breadcrumbs.alt1

+ +

+<!-- Breadcrumbs -->
+<ul class="breadcrumbs">
+<li><a href="">Home</a></li>
+<li><a href="">Category</a></li>
+<li><a href="">Sub Category</a></li>
+<li><a href="">Page Title</a></li>
+</ul>

+ +

+<!-- Alternative Style -->
+<ul class="breadcrumbs alt1">
+<li><a href="">Home</a></li>
+<li><a href="">Category</a></li>
+<li><a href="">Sub Category</a></li>
+<li><a href="">Page Title</a></li>
+</ul>

+ + + + +

Grids/Columns

Example
HTML

+ +

Responsive & Flexible Grid

Responsive functionality is optional. Only use .grid & .grid.flex if you + want a responsive grid. Resize your browser to see it in action.

Responsive Grid:
<div class="grid">

Flexible Responsive Grid:
<div class="grid flex">

Grid Helper Classes:
+ .show-desktop + .hide-desktop + .show-tablet + .hide-tablet + .show-phone + .hide-phone +

All columns automatically have the class .column. Apply padding and borders directly to columns +
.column{border:1px solid red;padding:10px;}

+ +

col_12

col_1

col_11

col_2

col_10

col_3

col_9

col_4

col_8

col_5

col_7

col_6

col_7

col_5

col_8

col_4

col_9

col_3

col_10

col_2

col_11

col_1

col_12

+ + +

Lorem ipsum dolor sit amet, consectetuer adipiscing elit, sed diam nonummy + nibh euismod tincidunt ut laoreet dolore magna aliquam erat volutpat. Ut wisi enim ad minim veniam.

+ + +

Lorem ipsum dolor sit amet, consectetuer adipiscing elit, sed diam nonummy + nibh euismod tincidunt ut laoreet dolore magna aliquam erat volutpat. Ut wisi enim ad minim veniam.

+ + +

Lorem ipsum dolor sit amet, consectetuer adipiscing elit, sed diam nonummy + nibh euismod tincidunt ut laoreet dolore magna aliquam erat volutpat. Ut wisi enim ad minim veniam.

+ +

+<!-- Columns/Grid -->
+<div class="col_12">col_12</div>
+<div class="col_1">col_1</div><div class="col_11">col_11</div>
+<div class="col_2">col_2</div><div class="col_10">col_10</div>
+<div class="col_3">col_3</div><div class="col_9">col_9</div>
+<div class="col_4">col_4</div><div class="col_8">col_8</div>
+<div class="col_5">col_5</div><div class="col_7">col_7</div>
+<div class="col_6">col_6</div><div class="col_6">col_6</div>
+<div class="col_7">col_7</div><div class="col_5">col_5</div>
+<div class="col_8">col_8</div><div class="col_4">col_4</div>
+<div class="col_9">col_9</div><div class="col_3">col_3</div>
+<div class="col_10">col_10</div><div class="col_2">col_2</div>
+<div class="col_11">col_11</div><div class="col_1">col_1</div>
+<div class="col_12">col_12</div>
+
+<!-- FOURTHS -->
+<div class="col_3">Lorem ipsum dolor sit amet, consectetuer adipiscing elit, sed diam nonummy 
+nibh euismod tincidunt ut laoreet dolore magna aliquam erat volutpat. Ut wisi enim ad minim veniam.</div>
+<div class="col_3">Lorem ipsum dolor sit amet, consectetuer adipiscing elit, sed diam nonummy 
+nibh euismod tincidunt ut laoreet dolore magna aliquam erat volutpat. Ut wisi enim ad minim veniam.</div>
+<div class="col_3">Lorem ipsum dolor sit amet, consectetuer adipiscing elit, sed diam nonummy 
+nibh euismod tincidunt ut laoreet dolore magna aliquam erat volutpat. Ut wisi enim ad minim veniam.</div>
+<div class="col_3">Lorem ipsum dolor sit amet, consectetuer adipiscing elit, sed diam nonummy 
+nibh euismod tincidunt ut laoreet dolore magna aliquam erat volutpat. Ut wisi enim ad minim veniam.</div>
+
+<!-- THIRDS -->
+<div class="col_4">Lorem ipsum dolor sit amet, consectetuer adipiscing elit, sed diam nonummy 
+nibh euismod tincidunt ut laoreet dolore magna aliquam erat volutpat. Ut wisi enim ad minim veniam.</div>
+<div class="col_4">Lorem ipsum dolor sit amet, consectetuer adipiscing elit, sed diam nonummy 
+nibh euismod tincidunt ut laoreet dolore magna aliquam erat volutpat. Ut wisi enim ad minim veniam.</div>
+<div class="col_4">Lorem ipsum dolor sit amet, consectetuer adipiscing elit, sed diam nonummy 
+nibh euismod tincidunt ut laoreet dolore magna aliquam erat volutpat. Ut wisi enim ad minim veniam.</div>
+
+<!-- HALF & HALF -->
+<div class="col_6">Lorem ipsum dolor sit amet, consectetuer adipiscing elit, sed diam nonummy 
+nibh euismod tincidunt ut laoreet dolore magna aliquam erat volutpat. Ut wisi enim ad minim veniam.</div>
+<div class="col_6">Lorem ipsum dolor sit amet, consectetuer adipiscing elit, sed diam nonummy 
+nibh euismod tincidunt ut laoreet dolore magna aliquam erat volutpat. Ut wisi enim ad minim veniam.</div>

+ + +

Images

Example
.caption
DIV.gallery
.align-left
.align-right
.full-width

+ +

IMG.caption

+ +

DIV.gallery

+ +

IMG.align-left

Lorem ipsum dolor sit amet, consectetuer adipiscing elit, sed diam nonummy nibh euismod tincidunt + ut laoreet dolore magna aliquam erat volutpat. Ut wisi enim ad minim veniam, quis nostrud exerci tation + ullamcorper suscipit lobortis nisl ut aliquip ex ea commodo consequat. Duis autem vel eum iriure dolor + in hendrerit in vulputate velit esse molestie consequat.

+ +

IMG.align-right

+ +

IMG.full-width

+ +

+<!-- Caption -->
+<img class="caption" title="This is the image caption" src="http://placehold.it/400x350/4D99E0/ffffff.png&text=400x350" width="400" height="350" />

+ +

+<!-- Align Left -->
+<img class="align-left" src="http://placehold.it/100x100/4D99E0/ffffff.png&text=100x100" width="100" height="100" />
+<p>Lorem ipsum dolor sit amet, consectetuer adipiscing elit, sed diam nonummy nibh euismod tincidunt 
+ut laoreet dolore magna aliquam erat volutpat. Ut wisi enim ad minim veniam, quis nostrud exerci tation 
+ullamcorper suscipit lobortis nisl ut aliquip ex ea commodo consequat. Duis autem vel eum iriure dolor 
+in hendrerit in vulputate velit esse molestie consequat.</p>

+ +

+<!-- Align Right -->
+<img class="align-right" src="http://placehold.it/100x100/4D99E0/ffffff.png&text=100x100" width="100" height="100" />
+<p>Lorem ipsum dolor sit amet, consectetuer adipiscing elit, sed diam nonummy nibh euismod tincidunt 
+ut laoreet dolore magna aliquam erat volutpat. Ut wisi enim ad minim veniam, quis nostrud exerci tation 
+ullamcorper suscipit lobortis nisl ut aliquip ex ea commodo consequat. Duis autem vel eum iriure dolor 
+in hendrerit in vulputate velit esse molestie consequat.</p>

+ +

+<!-- Full Width -->
+<img class="full-width" src="http://placehold.it/260x200/4D99E0/ffffff.png&text=full+width" />

+ +

+<!-- Gallery -->
+<div class="gallery">
+<a href="http://placehold.it/600x450/4D99E0/ffffff.png&text=600x450"><img src="http://placehold.it/100x100/4D99E0/ffffff.png&text=100x100" width="100" height="100" /></a>
+<a href="http://placehold.it/600x450/75CC00/ffffff.png&text=600x450"><img src="http://placehold.it/100x100/75CC00/ffffff.png&text=100x100" width="100" height="100" /></a>
+<a href="http://placehold.it/600x450/E49800/ffffff.png&text=600x450"><img src="http://placehold.it/100x100/E49800/ffffff.png&text=100x100" width="100" height="100" /></a>
+<a href="http://placehold.it/600x450/E4247E/ffffff.png&text=600x450"><img src="http://placehold.it/100x100/E4247E/ffffff.png&text=100x100" width="100" height="100" /></a>
+<a href="http://placehold.it/600x450/00C6E4/ffffff.png&text=600x450"><img src="http://placehold.it/100x100/00C6E4/ffffff.png&text=100x100" width="100" height="100" /></a>
+<a href="http://placehold.it/600x450/E4DB0F/ffffff.png&text=600x450"><img src="http://placehold.it/100x100/E4DB0F/ffffff.png&text=100x100" width="100" height="100" /></a>
+<a href="http://placehold.it/600x450/7400E4/ffffff.png&text=600x450"><img src="http://placehold.it/100x100/7400E4/ffffff.png&text=100x100" width="100" height="100" /></a>
+<a href="http://placehold.it/600x450/C50000/ffffff.png&text=600x450"><img src="http://placehold.it/100x100/C50000/ffffff.png&text=100x100" width="100" height="100" /></a>
+</div>

+ + +

Slideshow

Example
HTML

+ +

Fully responsive slideshow. Touch enabled. Uses the awesome & highly configurable BXSlider.

+ +

Features

Slide Any HTML Content
Responsive
Touch Enabled
Iframes
Videos
Images
Lightweight
Multiple Slideshows
Zero Setup Required
Unordered List (default)

+ +

+<!-- Slideshow -->
+<ul class="slideshow">
+<li><img src="http://placehold.it/550x350/4D99E0/ffffff.png&text=550x350" width="550" height="350" /></li>
+<li><img src="http://placehold.it/550x350/75CC00/ffffff.png&text=550x350" width="550" height="350" /></li>
+<li><img src="http://placehold.it/550x350/E49800/ffffff.png&text=550x350" width="550" height="350" /></li>
+<li><h3>Slide Anything</h3><p>Lorem ipsum dolor sit amet, consectetuer adipiscing elit, 
+sed diam nonummy nibh euismod tincidunt ut laoreet dolore magna aliquam erat volutpat.</p></li>
+</ul>

+ + + +

Forms

Example
Textfield
Select
Checkbox
Radio
Fieldset
Textarea
Notices

+ +

Form.vertical

+ +

Inline Form Fields (default)

+ +

+ + + +

Input/Label Sizes

+ + + label.col_10 + label.col_9 + label.col_8 + label.col_7 + label.col_6 + label.col_5 + label.col_4 + label.col_3 + label.col_2 + + +

+ +

+<!-- Text Field -->
+<label for="text1">Text Field</label>
+<input id="text1" type="text" />
+
+<!-- Placeholder Text -->
+<label for="text2">Placeholder</label>
+<input id="text2" type="text" placeholder="Placeholder Text" />
+
+<!-- Disabled Field -->
+<label for="text3" class="disabled">Disabled Field</label>
+<input id="text3" type="text" disabled="disabled" />
+
+<!-- Label with Right Hint -->
+<label for="text4">Label with Right Hint <span class="right">A-Z, 0-9</span></label>
+<input id="text4" type="text" />
+
+<!-- Label with Hint -->
+<label for="text5">Label with Hint <span>A-Z, 0-9</span></label>
+<input id="text5" type="text" />
+
+<!-- Text Field Error -->
+<label for="text6" class="error">Text Field (Error)</label>
+<input id="text6" class="error" type="text" />

+ +

+<!-- Select -->
+<label for="select1">Select Field</label>
+<select id="select1">
+<option value="0">-- Choose --</option>
+<option value="1">Option 1</option>
+<option value="2">Option 2</option>
+<option value="3">Option 3</option>
+</select>

+ +

+<!-- Checkbox -->
+<input type="checkbox" id="check1" />
+<label for="check1" class="inline">Checkbox Field</label>

+ +

+<!-- Radio -->
+<input type="radio" name="radio" id="radio1" />
+<label for="radio1" class="inline">Option1</label>

+ +

+<!-- Fieldset -->
+<fieldset>
+<legend>Checkboxes</legend>
+	<!-- Form Fields Here -->
+</fieldset>

+ +

+<!-- Textarea -->
+<textarea id="textarea1" placeholder="Placeholder Text"></textarea>

+ +

+<!-- Error -->
+<div class="notice error"><i class="icon-remove-sign icon-large"></i> This is an Error Notice 
+<a href="#close" class="icon-remove"></a></div>
+
+<!-- Warning -->
+<div class="notice warning"><i class="icon-warning-sign icon-large"></i> This is a Warning Notice 
+<a href="#close" class="icon-remove"></a></div>
+
+<!-- Success -->
+<div class="notice success"><i class="icon-ok icon-large"></i> This is a Success Notice 
+<a href="#close" class="icon-remove"></a></div>

+ + +

Extras/Helpers

Extras

+ +

+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +

Item	Description
`.left` `.center` `.right`	Align Text
`a.lightbox`	Open Link in lightbox. Auto Detects, iframe, inline content, etc.
`.clear`	Add this class to a div or other element to clear floats.
`.clearfix`	Add this class to containers that have floating children inside to clear inner floats.
`li.first` `li.last`	First and Last `<li></li>` items automatically get classes `.first` and `.last` respectively.
`.column`	All columns have the class `.column` added to them automatically for easy global styling.
`.visible`	Add this to columns to view during production. Adds light grey background color to columns.
`.hide` `.show`	`.hide` to hide content (display:none). `.show` to show content (display:block).
`tr.first` `tr.last`	First and Last `<tr></tr>` items automatically get classes `.first` and `.last` respectively.
`tr.alt`	Every second table row automatically gets class `.alt`.

+ + +

+ +

+ Download (Github) + + +
+

Downloaded over 91036 Times :)

+ + +

+ +

+ + + + +

+ + + + + ADDED cgisetup/www/example.html Index: cgisetup/www/example.html ================================================================== --- /dev/null +++ cgisetup/www/example.html @@ -0,0 +1,116 @@ + + +HTML KickStart Elements + + + + + + + + + + + + + +

+ + + +

Paragraphs

+ Lorem ipsum dolor sit amet, consectetuer adipiscing elit, sed diam nonummy nibh euismod + tincidunt ut laoreet dolore magna aliquam erat volutpat. Ut wisi enim ad minim veniam, quis + nostrud exerci tation ullamcorper suscipit lobortis nisl ut aliquip ex ea commodo consequat. + Duis autem vel eum iriure dolor in hendrerit in vulputate velit esse molestie consequat

+ +

El illum dolore eu feugiat nulla facilisis at vero eros et accumsan et iusto odio + dignissim qui blandit praesent luptatum zzril delenit augue duis dolore te feugait nulla facilisi. Nam + liber tempor cum soluta nobis eleifend <h1>Sample Code</h1> option + congue nihil imperdiet doming id quod mazim placerat facer possim assum.

+ +

+ Lorem ipsum dolor sit amet, consectetuer adipiscing elit, sed diam nonummy nibh euismod tincidunt ut laoreet dolore + magna aliquam erat volutpat. Ut wisi enim ad minim veniam, quis nostrud exerci tation ullamcorper suscipit lobortis + nisl ut aliquip ex ea commodo consequat. Duis autem vel eum iriure dolor in hendrerit in vulputate velit esse + molestie consequat, vel illum dolore eu feugiat nulla facilisis at vero eros et accumsan et iusto odio dignissim + qui blandit praesent luptatum zzril delenit augue duis dolore te feugait nulla facilisi. Nam liber tempor cum + soluta nobis eleifend option congue nihil imperdiet doming id quod mazim placerat facer possim assum.

+ +

Icon List

Apple
Banana
Orange
Pear

+ +

Sample Icons

+ + + + + +

Button w/Icon

+ RSS +

+ +

Column

+ +

Column

+ +

Column

+ +

Column

+ +

+ + +

+ + + ADDED cgisetup/www/index.html Index: cgisetup/www/index.html ================================================================== --- /dev/null +++ cgisetup/www/index.html @@ -0,0 +1,6 @@ + +blah + +Hello + + ADDED cgisetup/www/js/kickstart.js Index: cgisetup/www/js/kickstart.js ================================================================== --- /dev/null +++ cgisetup/www/js/kickstart.js @@ -0,0 +1,424 @@ +/* + 99Lime.com HTML KickStart by Joshua Gatcke + kickstart.js +*/ + +jQuery(document).ready(function($){ + + /*--------------------------------- + MENU Dropdowns + -----------------------------------*/ + $('ul.menu').each(function(){ + // add the menu toggle + $(this).prepend(''); + + // find menu items with children. + $(this).find('li').has('ul').addClass('has-menu') + .find('a:first').append(' '); + }); + + $('ul.menu li').hover(function(){ + $(this).find('ul:first').stop(true, true).fadeIn('fast'); + $(this).addClass('hover'); + }, + function(){ + $(this).find('ul').stop(true, true).fadeOut('slow'); + $(this).removeClass('hover'); + }); + + /*--------------------------------- + Slideshow + -----------------------------------*/ + $('.slideshow').bxSlider({ + mode: 'horizontal', // 'horizontal', 'vertical', 'fade' + video: true, + useCSS: true, + pager: true, + speed: 500, // transition time + startSlide: 0, + infiniteLoop: true, + captions: true, + adaptiveHeight: false, + touchEnabled: true, + pause: 4000, + autoControls: false, + controls: false, + autoStart: true, + auto: true + }); + + /*--------------------------------- + Fancybox Lightbox + -----------------------------------*/ + $('.gallery').each(function(i){ + $(this).find('a').attr('rel', 'gallery'+i) + .fancybox({ + overlayOpacity: 0.2, + overlayColor: '#000' + }); + }); + + // lightbox links + $('a.lightbox').fancybox({ + overlayOpacity: 0.2, + overlayColor: '#000' + }); + + /*--------------------------------- + Tabs + -----------------------------------*/ + // tab setup + $('.tab-content').addClass('clearfix').not(':first').hide(); + $('ul.tabs').each(function(){ + var current = $(this).find('li.current'); + if(current.length < 1) { $(this).find('li:first').addClass('current'); } + current = $(this).find('li.current a').attr('href'); + $(current).show(); + }); + + // tab click + $(document).on('click', 'ul.tabs a[href^="#"]', function(e){ + e.preventDefault(); + var tabs = $(this).parents('ul.tabs').find('li'); + var tab_next = $(this).attr('href'); + var tab_current = tabs.filter('.current').find('a').attr('href'); + $(tab_current).hide(); + tabs.removeClass('current'); + $(this).parent().addClass('current'); + $(tab_next).show(); + history.pushState( null, null, window.location.search + $(this).attr('href') ); + return false; + }); + + // tab hashtag identification and auto-focus + var wantedTag = window.location.hash; + if (wantedTag != "") + { + // This code can and does fail, hard, killing the entire app. + // Esp. when used with the jQuery.Address project. + try { + var allTabs = $("ul.tabs a[href^=" + wantedTag + "]").parents('ul.tabs').find('li'); + var defaultTab = allTabs.filter('.current').find('a').attr('href'); + $(defaultTab).hide(); + allTabs.removeClass('current'); + $("ul.tabs a[href^=" + wantedTag + "]").parent().addClass('current'); + $("#" + wantedTag.replace('#','')).show(); + } catch(e) { + // I have no idea what to do here, so I'm leaving this for the maintainer. + } + } + + /*--------------------------------- + Image Caption + -----------------------------------*/ + $('img.caption').each(function(){ + $(this).wrap('

'); + $(this).parents('div.caption') + .attr('class', 'img-wrap '+$(this).attr('class')); + if($(this).attr('title')){ + $(this).parents('div.caption') + .append(''+$(this).attr('title')+''); + } + }); + + /*--------------------------------- + Notice + -----------------------------------*/ + $(document).on('click', '.notice a[class^="icon-remove"]', function(e){ + e.preventDefault(); + var notice = $(this).parents('.notice'); + $(this).hide(); + notice.fadeOut('slow'); + }); + + /*--------------------------------- + ToolTip - TipTip + -----------------------------------*/ + + // Standard tooltip + $('.tooltip, .tooltip-top, .tooltip-bottom, .tooltip-right, .tooltip-left').each(function(){ + // variables + var tpos = 'top'; + var content = $(this).attr('title'); + var dataContent = $(this).attr('data-content'); + var keepAlive = false; + var action = 'hover'; + var delay = $(this).attr('data-delay'); + if (delay === undefined) {delay = 1000;} + + // position + if($(this).hasClass('tooltip-top')) { tpos = 'top'; } + if($(this).hasClass('tooltip-right')) { tpos = 'right'; } + if($(this).hasClass('tooltip-bottom')) { tpos = 'bottom'; } + if($(this).hasClass('tooltip-left')) { tpos = 'left'; } + + // content + $('.tooltip-content').removeClass('hide').wrap(''); + if(dataContent) { content = $(dataContent).html(); keepAlive = true; } + + // action (hover or click) defaults to hover + if($(this).attr('data-action') == 'click') { action = 'click'; } + + // tooltip + $(this).attr('title','') + .tipTip({defaultPosition: tpos, content: content, keepAlive: keepAlive, activation: action, delay: delay}); + }); + + /*--------------------------------- + Table Sort + -----------------------------------*/ + // init + var aAsc = []; + $('table.sortable').each(function(){ + $(this).find('thead th').each(function(index){$(this).attr('rel', index);}); + $(this).find('th,td').each(function(){$(this).attr('value', $(this).text());}); + }); + + // table click + $(document).on('click', 'table.sortable thead th', function(e){ + // update arrow icon + $(this).parents('table.sortable').find('span.arrow').remove(); + $(this).append(''); + + // sort direction + var nr = $(this).attr('rel'); + aAsc[nr] = aAsc[nr]=='asc'?'desc':'asc'; + if(aAsc[nr] == 'desc'){ $(this).find('span.arrow').addClass('up'); } + + // sort rows + var rows = $(this).parents('table.sortable').find('tbody tr'); + rows.tsort('td:eq('+nr+')',{order:aAsc[nr],attr:'value'}); + + // fix row classes + rows.removeClass('alt first last'); + var table = $(this).parents('table.sortable'); + table.find('tr:even').addClass('alt'); + table.find('tr:first').addClass('first'); + table.find('tr:last').addClass('last'); + }); + + /*--------------------------------- + CSS Helpers + -----------------------------------*/ + $('input[type=checkbox]').addClass('checkbox'); + $('input[type=radio]').addClass('radio'); + $('input[type=file]').addClass('file'); + $('[disabled=disabled]').addClass('disabled'); + $('table').find('tr:even').addClass('alt'); + $('table').find('tr:first-child').addClass('first'); + $('table').find('tr:last-child').addClass('last'); + $('ul').find('li:first-child').addClass('first'); + $('ul').find('li:last-child').addClass('last'); + $('hr').before('

'); + $('[class*="col_"]').addClass('column'); + $('pre').addClass('prettyprint');prettyPrint(); + +}); + +/* + * FancyBox - jQuery Plugin + * Simple and fancy lightbox alternative + * + * Examples and documentation at: http://fancybox.net + * + * Copyright (c) 2008 - 2010 Janis Skarnelis + * That said, it is hardly a one-person project. Many people have submitted bugs, code, and offered their advice freely. Their support is greatly appreciated. + * + * Version: 1.3.4 (11/11/2010) + * Requires: jQuery v1.3+ + * + * Dual licensed under the MIT and GPL licenses: + * http://www.opensource.org/licenses/mit-license.php + * http://www.gnu.org/licenses/gpl.html + */ +(function(a){var p,u,v,e,B,m,C,j,y,z,s=0,d={},q=[],r=0,c={},k=[],E=null,n=new Image,H=/\.(jpg|gif|png|bmp|jpeg)(.*)?$/i,S=/[^\.]\.(swf)\s*$/i,I,J=1,x=0,w="",t,g,l=!1,A=a.extend(a("

")[0],{prop:0}),K=navigator.userAgent.match(/msie [6]/i)&&!window.XMLHttpRequest,L=function(){u.hide();n.onerror=n.onload=null;E&&E.abort();p.empty()},M=function(){!1===d.onError(q,s,d)?(u.hide(),l=!1):(d.titleShow=!1,d.width="auto",d.height="auto",p.html('

The requested content cannot be loaded.
Please try again later.

'), +D())},G=function(){var b=q[s],c,f,e,g,k,j;L();d=a.extend({},a.fn.fancybox.defaults,"undefined"==typeof a(b).data("fancybox")?d:a(b).data("fancybox"));j=d.onStart(q,s,d);if(!1===j)l=!1;else{"object"==typeof j&&(d=a.extend(d,j));e=d.title||(b.nodeName?a(b).attr("title"):b.title)||"";b.nodeName&&!d.orig&&(d.orig=a(b).children("img:first").length?a(b).children("img:first"):a(b));""===e&&(d.orig&&d.titleFromAlt)&&(e=d.orig.attr("alt"));c=d.href||(b.nodeName?a(b).attr("href"):b.href)||null;if(/^(?:javascript)/i.test(c)|| +"#"==c)c=null;d.type?(f=d.type,c||(c=d.content)):d.content?f="html":c&&(f=c.match(H)?"image":c.match(S)?"swf":a(b).hasClass("iframe")?"iframe":0===c.indexOf("#")?"inline":"ajax");if(f)switch("inline"==f&&(b=c.substr(c.indexOf("#")),f=0').hide().insertBefore(a(b)).bind("fancybox-cleanup",function(){a(this).replaceWith(m.children())}).bind("fancybox-cancel", +function(){a(this).replaceWith(p.children())});a(b).appendTo(p);D();break;case "image":l=!1;a.fancybox.showActivity();n=new Image;n.onerror=function(){M()};n.onload=function(){l=!0;n.onerror=n.onload=null;d.width=n.width;d.height=n.height;a("").attr({id:"fancybox-img",src:n.src,alt:d.title}).appendTo(p);N()};n.src=c;break;case "swf":d.scrolling="no";g='

";p.html(g);D();break;case "ajax":l=!1;a.fancybox.showActivity();d.ajax.win=d.ajax.success;E=a.ajax(a.extend({},d.ajax,{url:c,data:d.ajax.data||{},error:function(a){0

');d.width=p.width();d.height=p.height();N()},N=function(){var b,h;u.hide();if(e.is(":visible")&&!1===c.onCleanup(k,r,c))a.event.trigger("fancybox-cancel"),l=!1;else{l=!0;a(m.add(v)).unbind();a(window).unbind("resize.fb scroll.fb");a(document).unbind("keydown.fb");e.is(":visible")&&"outside"!==c.titlePosition&&e.css("height",e.height());k=q;r=s;c=d;if(c.overlayShow){if(v.css({"background-color":c.overlayColor,opacity:c.overlayOpacity, +cursor:c.hideOnOverlayClick?"pointer":"auto",height:a(document).height()}),!v.is(":visible")){if(K)a("select:not(#fancybox-tmp select)").filter(function(){return"hidden"!==this.style.visibility}).css({visibility:"hidden"}).one("fancybox-cleanup",function(){this.style.visibility="inherit"});v.show()}}else v.hide();b=O();var f={},F=c.autoScale,n=2*c.padding;f.width=-1b[0]||f.height>b[1]))"image"==d.type||"swf"==d.type?(F=c.width/c.height,f.width>b[0]&&(f.width=b[0],f.height=parseInt((f.width-n)/F+n,10)),f.height>b[1]&&(f.height=b[1],f.width=parseInt((f.height-n)*F+n,10))):(f.width=Math.min(f.width,b[0]),f.height=Math.min(f.height,b[1]));f.top=parseInt(Math.max(b[3]-20,b[3]+0.5*(b[1]-f.height-40)),10);f.left=parseInt(Math.max(b[2]-20,b[2]+0.5*(b[0]-f.width-40)),10);g=f;w=c.title||"";x=0;j.empty().removeAttr("style").removeClass(); +if(!1!==c.titleShow&&(w=a.isFunction(c.titleFormat)?c.titleFormat(w,k,r,c):w&&w.length?"float"==c.titlePosition?'

'+w+'

':'

'+w+"

":!1)&&""!==w)switch(j.addClass("fancybox-title-"+c.titlePosition).html(w).appendTo("body").show(),c.titlePosition){case "inside":j.css({width:g.width- +2*c.padding,marginLeft:c.padding,marginRight:c.padding});x=j.outerHeight(!0);j.appendTo(B);g.height+=x;break;case "over":j.css({marginLeft:c.padding,width:g.width-2*c.padding,bottom:c.padding}).appendTo(B);break;case "float":j.css("left",-1*parseInt((j.width()-g.width-40)/2,10)).appendTo(e);break;default:j.css({width:g.width-2*c.padding,paddingLeft:c.padding,paddingRight:c.padding}).appendTo(e)}j.hide();e.is(":visible")?(a(C.add(y).add(z)).hide(),b=e.position(),t={top:b.top,left:b.left,width:e.width(), +height:e.height()},h=t.width==g.width&&t.height==g.height,m.fadeTo(c.changeFade,0.3,function(){var b=function(){m.html(p.contents()).fadeTo(c.changeFade,1,P)};a.event.trigger("fancybox-change");m.empty().removeAttr("filter").css({"border-width":c.padding,width:g.width-2*c.padding,height:d.autoDimensions?"auto":g.height-x-2*c.padding});h?b():(A.prop=0,a(A).animate({prop:1},{duration:c.changeSpeed,easing:c.easingChange,step:Q,complete:b}))})):(e.removeAttr("style"),m.css("border-width",c.padding),"elastic"== +c.transitionIn?(t=R(),m.html(p.contents()),e.show(),c.opacity&&(g.opacity=0),A.prop=0,a(A).animate({prop:1},{duration:c.speedIn,easing:c.easingIn,step:Q,complete:P})):("inside"==c.titlePosition&&0').appendTo(m);e.show();l=!1;a.fancybox.center();c.onComplete(k,r,c);var b,h;k.length-1>r&&(b=k[r+1].href,"undefined"!==typeof b&&b.match(H)&&(h=new Image,h.src=b));0b?0.5:b);e.css(a);m.css({width:a.width-2*c.padding,height:a.height-x*b-2*c.padding})},O=function(){return[a(window).width()-2*c.margin,a(window).height()-2*c.margin,a(document).scrollLeft()+c.margin,a(document).scrollTop()+c.margin]},R=function(){var b=d.orig?a(d.orig):!1,h={};b&&b.length?(h=b.offset(),h.top+=parseInt(b.css("paddingTop"),10)||0,h.left+=parseInt(b.css("paddingLeft"),10)||0,h.top+=parseInt(b.css("border-top-width"),10)||0,h.left+= +parseInt(b.css("border-left-width"),10)||0,h.width=b.width(),h.height=b.height(),h={width:h.width+2*c.padding,height:h.height+2*c.padding,top:h.top-c.padding-20,left:h.left-c.padding-20}):(b=O(),h={width:2*c.padding,height:2*c.padding,top:parseInt(b[3]+0.5*b[1],10),left:parseInt(b[2]+0.5*b[0],10)});return h},T=function(){u.is(":visible")?(a("div",u).css("top",-40*J+"px"),J=(J+1)%12):clearInterval(I)};a.fn.fancybox=function(b){if(!a(this).length)return this;a(this).data("fancybox",a.extend({},b,a.metadata? +a(this).metadata():{})).unbind("click.fb").bind("click.fb",function(b){b.preventDefault();l||(l=!0,a(this).blur(),q=[],s=0,b=a(this).attr("rel")||"",!b||""==b||"nofollow"===b?q.push(this):(q=a("a[rel="+b+"], area[rel="+b+"], img[rel="+b+"]"),s=q.index(this)),G())});return this};a.fancybox=function(b,c){var d;if(!l){l=!0;d="undefined"!==typeof c?c:{};q=[];s=parseInt(d.index,10)||0;if(a.isArray(b)){for(var e=0,g=b.length;eq.length||0>s)s=0;G()}};a.fancybox.showActivity=function(){clearInterval(I);u.show();I=setInterval(T,66)};a.fancybox.hideActivity=function(){u.hide()};a.fancybox.next=function(){return a.fancybox.pos(r+1)};a.fancybox.prev=function(){return a.fancybox.pos(r-1)};a.fancybox.pos=function(b){l||(b=parseInt(b), +q=k,-1=k.length?0:k.length-1,G()))};a.fancybox.cancel=function(){l||(l=!0,a.event.trigger("fancybox-cancel"),L(),d.onCancel(q,s,d),l=!1)};a.fancybox.close=function(){function b(){v.fadeOut("fast");j.empty().hide();e.hide();a.event.trigger("fancybox-cleanup");m.empty();c.onClosed(k,r,c);k=d=[];r=s=0;c=d={};l=!1}if(!l&&!e.is(":hidden"))if(l=!0,c&&!1===c.onCleanup(k,r,c))l=!1;else if(L(),a(C.add(y).add(z)).hide(),a(m.add(v)).unbind(),a(window).unbind("resize.fb scroll.fb"), +a(document).unbind("keydown.fb"),m.find("iframe").attr("src",K&&/^https/i.test(window.location.href||"")?"javascript:void(false)":"about:blank"),"inside"!==c.titlePosition&&j.empty(),e.stop(),"elastic"==c.transitionOut){t=R();var h=e.position();g={top:h.top,left:h.left,width:e.width(),height:e.height()};c.opacity&&(g.opacity=1);j.empty().hide();A.prop=1;a(A).animate({prop:0},{duration:c.speedOut,easing:c.easingOut,step:Q,complete:b})}else e.fadeOut("none"==c.transitionOut?0:c.speedOut,b)};a.fancybox.resize= +function(){v.is(":visible")&&v.css("height",a(document).height());a.fancybox.center(!0)};a.fancybox.center=function(b){var a,d;if(!l&&(d=!0===b?1:0,a=O(),d||!(e.width()>a[0]||e.height()>a[1])))e.stop().animate({top:parseInt(Math.max(a[3]-20,a[3]+0.5*(a[1]-m.height()-40)-c.padding)),left:parseInt(Math.max(a[2]-20,a[2]+0.5*(a[0]-m.width()-40)-c.padding))},"number"==typeof b?b:200)};a.fancybox.init=function(){a("#fancybox-wrap").length||(a("body").append(p=a('

'),u=a('

'), +v=a('

'),e=a('

')),B=a('

').append('

').appendTo(e), +B.append(m=a('

'),C=a(''),j=a('

'),y=a(''),z=a('')),C.click(a.fancybox.close),u.click(a.fancybox.cancel),y.click(function(b){b.preventDefault();a.fancybox.prev()}),z.click(function(b){b.preventDefault();a.fancybox.next()}), +a.fn.mousewheel&&e.bind("mousewheel.fb",function(b,c){if(l)b.preventDefault();else if(0==a(b.target).get(0).clientHeight||a(b.target).get(0).scrollHeight===a(b.target).get(0).clientHeight)b.preventDefault(),a.fancybox[0').prependTo(B)))}; +a.fn.fancybox.defaults={padding:10,margin:40,opacity:!1,modal:!1,cyclic:!1,scrolling:"auto",width:560,height:340,autoScale:!0,autoDimensions:!0,centerOnScroll:!1,ajax:{},swf:{wmode:"transparent"},hideOnOverlayClick:!0,hideOnContentClick:!1,overlayShow:!0,overlayOpacity:0.7,overlayColor:"#777",titleShow:!0,titlePosition:"float",titleFormat:null,titleFromAlt:!1,transitionIn:"fade",transitionOut:"fade",speedIn:300,speedOut:300,changeSpeed:300,changeFade:"fast",easingIn:"swing",easingOut:"swing",showCloseButton:!0, +showNavArrows:!0,enableEscapeButton:!0,enableKeyboardNav:!0,onStart:function(){},onCancel:function(){},onComplete:function(){},onCleanup:function(){},onClosed:function(){},onError:function(){}};a(document).ready(function(){a.fancybox.init()})})(jQuery); + + + /* + * TipTip + * Copyright 2010 Drew Wilson + * www.drewwilson.com + * code.drewwilson.com/entry/tiptip-jquery-plugin + * + * Version 1.3 - Updated: Mar. 23, 2010 + * + * This Plug-In will create a custom tooltip to replace the default + * browser tooltip. It is extremely lightweight and very smart in + * that it detects the edges of the browser window and will make sure + * the tooltip stays within the current window size. As a result the + * tooltip will adjust itself to be displayed above, below, to the left + * or to the right depending on what is necessary to stay within the + * browser window. It is completely customizable as well via CSS. + * + * This TipTip jQuery plug-in is dual licensed under the MIT and GPL licenses: + * http://www.opensource.org/licenses/mit-license.php + * http://www.gnu.org/licenses/gpl.html + */ +(function($){$.fn.tipTip=function(options){var defaults={activation:"hover",keepAlive:false,maxWidth:"200px",edgeOffset:3,defaultPosition:"bottom",delay:400,fadeIn:200,fadeOut:200,attribute:"title",content:false,enter:function(){},exit:function(){}};var opts=$.extend(defaults,options);if($("#tiptip_holder").length<=0){var tiptip_holder=$('

');var tiptip_content=$('

');var tiptip_arrow=$('

');$("body").append(tiptip_holder.html(tiptip_content).prepend(tiptip_arrow.html('

')))}else{var tiptip_holder=$("#tiptip_holder");var tiptip_content=$("#tiptip_content");var tiptip_arrow=$("#tiptip_arrow")}return this.each(function(){var org_elem=$(this);if(opts.content){var org_title=opts.content}else{var org_title=org_elem.attr(opts.attribute)}if(org_title!=""){if(!opts.content){org_elem.removeAttr(opts.attribute)}var timeout=false;if(opts.activation=="hover"){org_elem.hover(function(){active_tiptip()},function(){if(!opts.keepAlive){deactive_tiptip()}});if(opts.keepAlive){tiptip_holder.hover(function(){},function(){deactive_tiptip()})}}else if(opts.activation=="focus"){org_elem.focus(function(){active_tiptip()}).blur(function(){deactive_tiptip()})}else if(opts.activation=="click"){org_elem.click(function(){active_tiptip();return false}).hover(function(){},function(){if(!opts.keepAlive){deactive_tiptip()}});if(opts.keepAlive){tiptip_holder.hover(function(){},function(){deactive_tiptip()})}}function active_tiptip(){opts.enter.call(this);tiptip_content.html(org_title);tiptip_holder.hide().removeAttr("class").css("margin","0");tiptip_arrow.removeAttr("style");var top=parseInt(org_elem.offset()['top']);var left=parseInt(org_elem.offset()['left']);var org_width=parseInt(org_elem.outerWidth());var org_height=parseInt(org_elem.outerHeight());var tip_w=tiptip_holder.outerWidth();var tip_h=tiptip_holder.outerHeight();var w_compare=Math.round((org_width-tip_w)/2);var h_compare=Math.round((org_height-tip_h)/2);var marg_left=Math.round(left+w_compare);var marg_top=Math.round(top+org_height+opts.edgeOffset);var t_class="";var arrow_top="";var arrow_left=Math.round(tip_w-12)/2;if(opts.defaultPosition=="bottom"){t_class="_bottom"}else if(opts.defaultPosition=="top"){t_class="_top"}else if(opts.defaultPosition=="left"){t_class="_left"}else if(opts.defaultPosition=="right"){t_class="_right"}var right_compare=(w_compare+left)parseInt($(window).width());if((right_compare&&w_compare<0)||(t_class=="_right"&&!left_compare)||(t_class=="_left"&&left<(tip_w+opts.edgeOffset+5))){t_class="_right";arrow_top=Math.round(tip_h-13)/2;arrow_left=-12;marg_left=Math.round(left+org_width+opts.edgeOffset);marg_top=Math.round(top+h_compare)}else if((left_compare&&w_compare<0)||(t_class=="_left"&&!right_compare)){t_class="_left";arrow_top=Math.round(tip_h-13)/2;arrow_left=Math.round(tip_w);marg_left=Math.round(left-(tip_w+opts.edgeOffset+5));marg_top=Math.round(top+h_compare)}var top_compare=(top+org_height+opts.edgeOffset+tip_h+8)>parseInt($(window).height()+$(window).scrollTop());var bottom_compare=((top+org_height)-(opts.edgeOffset+tip_h+8))<0;if(top_compare||(t_class=="_bottom"&&top_compare)||(t_class=="_top"&&!bottom_compare)){if(t_class=="_top"||t_class=="_bottom"){t_class="_top"}else{t_class=t_class+"_top"}arrow_top=tip_h;marg_top=Math.round(top-(tip_h+5+opts.edgeOffset))}else if(bottom_compare|(t_class=="_top"&&bottom_compare)||(t_class=="_bottom"&&!top_compare)){if(t_class=="_top"||t_class=="_bottom"){t_class="_bottom"}else{t_class=t_class+"_bottom"}arrow_top=-12;marg_top=Math.round(top+org_height+opts.edgeOffset)}if(t_class=="_right_top"||t_class=="_left_top"){marg_top=marg_top+5}else if(t_class=="_right_bottom"||t_class=="_left_bottom"){marg_top=marg_top-5}if(t_class=="_left_top"||t_class=="_left_bottom"){marg_left=marg_left+5}tiptip_arrow.css({"margin-left":arrow_left+"px","margin-top":arrow_top+"px"});tiptip_holder.css({"margin-left":marg_left+"px","margin-top":marg_top+"px"}).attr("class","tip"+t_class);if(timeout){clearTimeout(timeout)}timeout=setTimeout(function(){tiptip_holder.stop(true,true).fadeIn(opts.fadeIn)},opts.delay)}function deactive_tiptip(){opts.exit.call(this);if(timeout){clearTimeout(timeout)}tiptip_holder.fadeOut(opts.fadeOut)}}})}})(jQuery); + +/* TINY SORT */ +(function(e){var a=false,g=null,f=parseFloat,b=/(\d+\.?\d*)$/g;e.tinysort={id:"TinySort",version:"1.2.18",copyright:"Copyright (c) 2008-2012 Ron Valstar",uri:"http://tinysort.sjeiti.com/",licenced:{MIT:"http://www.opensource.org/licenses/mit-license.php",GPL:"http://www.gnu.org/licenses/gpl.html"},defaults:{order:"asc",attr:g,data:g,useVal:a,place:"start",returns:a,cases:a,forceStrings:a,sortFunction:g}};e.fn.extend({tinysort:function(m,h){if(m&&typeof(m)!="string"){h=m;m=g}var n=e.extend({},e.tinysort.defaults,h),s,B=this,x=e(this).length,C={},p=!(!m||m==""),q=!(n.attr===g||n.attr==""),w=n.data!==g,j=p&&m[0]==":",k=j?B.filter(m):B,r=n.sortFunction,v=n.order=="asc"?1:-1,l=[];if(!r){r=n.order=="rand"?function(){return Math.random()<0.5?1:-1}:function(F,E){var i=!n.cases?d(F.s):F.s,K=!n.cases?d(E.s):E.s;if(!n.forceStrings){var H=i.match(b),G=K.match(b);if(H&&G){var J=i.substr(0,i.length-H[0].length),I=K.substr(0,K.length-G[0].length);if(J==I){i=f(H[0]);K=f(G[0])}}}return v*(iK?1:0))}}B.each(function(G,H){var I=e(H),E=p?(j?k.filter(H):I.find(m)):I,J=w?E.data(n.data):(q?E.attr(n.attr):(n.useVal?E.val():E.text())),F=I.parent();if(!C[F]){C[F]={s:[],n:[]}}if(E.length>0){C[F].s.push({s:J,e:I,n:G})}else{C[F].n.push({e:I,n:G})}});for(s in C){C[s].s.sort(r)}for(s in C){var y=C[s],A=[],D=x,u=[0,0],z;switch(n.place){case"first":e.each(y.s,function(E,F){D=Math.min(D,F.n)});break;case"org":e.each(y.s,function(E,F){A.push(F.n)});break;case"end":D=y.n.length;break;default:D=0}for(z=0;z=D&&z

').parent('.fluid-width-video-wrapper').css('padding-top', (aspectRatio * 100)+"%"); + $this.removeAttr('height').removeAttr('width'); + }); + }); + }; +})( jQuery ); + + +/** + * BxSlider v4.0 - Fully loaded, responsive content slider + * http://bxslider.com + * + * Copyright 2012, Steven Wanderski - http://stevenwanderski.com - http://bxcreative.com + * Written while drinking Belgian ales and listening to jazz + * + * Released under the WTFPL license - http://sam.zoy.org/wtfpl/ + */ +(function(t){var e={},n={mode:"horizontal",slideSelector:"",infiniteLoop:!0,hideControlOnEnd:!1,speed:500,easing:null,slideMargin:0,startSlide:0,randomStart:!1,captions:!1,ticker:!1,tickerHover:!1,adaptiveHeight:!1,adaptiveHeightSpeed:500,touchEnabled:!0,swipeThreshold:50,video:!1,useCSS:!0,pager:!0,pagerType:"full",pagerShortSeparator:" / ",pagerSelector:null,buildPager:null,pagerCustom:null,controls:!0,nextText:"Next",prevText:"Prev",nextSelector:null,prevSelector:null,autoControls:!1,startText:"Start",stopText:"Stop",autoControlsCombine:!1,autoControlsSelector:null,auto:!1,pause:4e3,autoStart:!0,autoDirection:"next",autoHover:!1,autoDelay:0,minSlides:1,maxSlides:1,moveSlides:0,slideWidth:0,onSliderLoad:function(){},onSlideBefore:function(){},onSlideAfter:function(){},onSlideNext:function(){},onSlidePrev:function(){}};t.fn.bxSlider=function(s){if(0!=this.length){if(this.length>1)return this.each(function(){t(this).bxSlider(s)}),this;var o={},r=this;e.el=this;var a=t(window).width(),l=t(window).height(),d=function(){o.settings=t.extend({},n,s),o.children=r.children(o.settings.slideSelector),o.children.length1||o.settings.maxSlides>1,o.minThreshold=o.settings.minSlides*o.settings.slideWidth+(o.settings.minSlides-1)*o.settings.slideMargin,o.maxThreshold=o.settings.maxSlides*o.settings.slideWidth+(o.settings.maxSlides-1)*o.settings.slideMargin,o.working=!1,o.controls={},o.interval=null,o.animProp="vertical"==o.settings.mode?"top":"left",o.usingCSS=o.settings.useCSS&&"fade"!=o.settings.mode&&function(){var t=document.createElement("div"),e=["WebkitPerspective","MozPerspective","OPerspective","msPerspective"];for(var i in e)if(void 0!==t.style[e[i]])return o.cssPrefix=e[i].replace("Perspective","").toLowerCase(),o.animProp="-"+o.cssPrefix+"-transform",!0;return!1}(),"vertical"==o.settings.mode&&(o.settings.maxSlides=o.settings.minSlides),c()},c=function(){if(r.wrap('

'),o.viewport=r.parent(),o.loader=t('

'),o.viewport.prepend(o.loader),r.css({width:"horizontal"==o.settings.mode?215*o.children.length+"%":"auto",position:"relative"}),o.usingCSS&&o.settings.easing?r.css("-"+o.cssPrefix+"-transition-timing-function",o.settings.easing):o.settings.easing||(o.settings.easing="swing"),o.viewport.css({width:"100%",overflow:"hidden",position:"relative"}),o.children.css({"float":"horizontal"==o.settings.mode?"left":"none",listStyle:"none",position:"relative"}),o.children.width(h()),"horizontal"==o.settings.mode&&o.settings.slideMargin>0&&o.children.css("marginRight",o.settings.slideMargin),"vertical"==o.settings.mode&&o.settings.slideMargin>0&&o.children.css("marginBottom",o.settings.slideMargin),"fade"==o.settings.mode&&(o.children.css({position:"absolute",zIndex:0,display:"none"}),o.children.eq(o.settings.startSlide).css({zIndex:50,display:"block"})),o.controls.el=t('

'),o.settings.captions&&T(),o.settings.infiniteLoop&&"fade"!=o.settings.mode&&!o.settings.ticker){var e="vertical"==o.settings.mode?o.settings.minSlides:o.settings.maxSlides,i=o.children.slice(0,e).clone().addClass("bx-clone"),n=o.children.slice(-e).clone().addClass("bx-clone");r.append(i).prepend(n)}o.active.last=o.settings.startSlide==v()-1,o.settings.video&&r.fitVids(),o.settings.ticker||(o.settings.pager&&S(),o.settings.controls&&b(),o.settings.auto&&o.settings.autoControls&&w(),(o.settings.controls||o.settings.autoControls||o.settings.pager)&&o.viewport.after(o.controls.el)),r.children().imagesLoaded(function(){o.loader.remove(),f(),"vertical"==o.settings.mode&&(o.settings.adaptiveHeight=!0),o.viewport.height(g()),o.settings.onSliderLoad(o.active.index),o.initialized=!0,t(window).bind("resize",O),o.settings.auto&&o.settings.autoStart&&L(),o.settings.ticker&&D(),o.settings.pager&&y(o.settings.startSlide),o.settings.controls&&q(),o.settings.touchEnabled&&!o.settings.ticker&&H()})},g=function(){var e=0,n=t();if("vertical"==o.settings.mode||o.settings.adaptiveHeight)if(o.carousel){var s=1==o.settings.moveSlides?o.active.index:o.active.index*p();for(n=o.children.eq(s),i=1;o.settings.maxSlides-1>=i;i++)n=s+i>=o.children.length?n.add(o.children.eq(i-1)):n.add(o.children.eq(s+i))}else n=o.children.eq(o.active.index);else n=o.children;return"vertical"==o.settings.mode?(n.each(function(){e+=t(this).outerHeight()}),o.settings.slideMargin>0&&(e+=o.settings.slideMargin*(o.settings.minSlides-1))):e=Math.max.apply(Math,n.map(function(){return t(this).outerHeight(!1)}).get()),e},h=function(){var t=o.settings.slideWidth,e=o.viewport.width();return 0==o.settings.slideWidth?t=e:e>o.maxThreshold?t=(e-o.settings.slideMargin*(o.settings.maxSlides-1))/o.settings.maxSlides:o.minThreshold>e&&(t=(e-o.settings.slideMargin*(o.settings.minSlides-1))/o.settings.minSlides),t},u=function(){var t=1;if("horizontal"==o.settings.mode)if(o.viewport.width()o.maxThreshold)t=o.settings.maxSlides;else{var e=o.children.first().width();t=Math.floor(o.viewport.width()/e)}else"vertical"==o.settings.mode&&(t=o.settings.minSlides);return t},v=function(){var t=0;if(o.settings.moveSlides>0)if(o.settings.infiniteLoop)t=o.children.length/p();else for(var e=0,i=0;o.children.length>e;)++t,e=i+u(),i+=o.settings.moveSlides<=u()?o.settings.moveSlides:u();else t=Math.ceil(o.children.length/u());return t},p=function(){return o.settings.moveSlides>0&&o.settings.moveSlides<=u()?o.settings.moveSlides:u()},f=function(){if(o.active.last&&!o.settings.infiniteLoop){if("horizontal"==o.settings.mode){var t=o.children.last(),e=t.position();x(-(e.left-(o.viewport.width()-t.width())),"reset",0)}else if("vertical"==o.settings.mode){var i=o.children.length-o.settings.minSlides,e=o.children.eq(i).position();x(-e.top,"reset",0)}}else{var e=o.children.eq(o.active.index*p()).position();o.active.index==v()-1&&(o.active.last=!0),void 0!=e&&("horizontal"==o.settings.mode?x(-e.left,"reset",0):"vertical"==o.settings.mode&&x(-e.top,"reset",0))}},x=function(t,e,i,n){if(o.usingCSS){var s="vertical"==o.settings.mode?"translate3d(0, "+t+"px, 0)":"translate3d("+t+"px, 0, 0)";r.css("-"+o.cssPrefix+"-transition-duration",i/1e3+"s"),"slide"==e?(r.css(o.animProp,s),r.bind("transitionend webkitTransitionEnd oTransitionEnd MSTransitionEnd",function(){r.unbind("transitionend webkitTransitionEnd oTransitionEnd MSTransitionEnd"),z()})):"reset"==e?r.css(o.animProp,s):"ticker"==e&&(r.css("-"+o.cssPrefix+"-transition-timing-function","linear"),r.css(o.animProp,s),r.bind("transitionend webkitTransitionEnd oTransitionEnd MSTransitionEnd",function(){r.unbind("transitionend webkitTransitionEnd oTransitionEnd MSTransitionEnd"),x(n.resetValue,"reset",0),I()}))}else{var a={};a[o.animProp]=t,"slide"==e?r.animate(a,i,o.settings.easing,function(){z()}):"reset"==e?r.css(o.animProp,t):"ticker"==e&&r.animate(a,speed,"linear",function(){x(n.resetValue,"reset",0),I()})}},m=function(){var e="";pagerQty=v();for(var i=0;pagerQty>i;i++){var n="";o.settings.buildPager&&t.isFunction(o.settings.buildPager)?(n=o.settings.buildPager(i),o.pagerEl.addClass("bx-custom-pager")):(n=i+1,o.pagerEl.addClass("bx-default-pager")),e+='"}o.pagerEl.html(e)},S=function(){o.settings.pagerCustom?o.pagerEl=t(o.settings.pagerCustom):(o.pagerEl=t('

'),o.settings.pagerSelector?t(o.settings.pagerSelector).html(o.pagerEl):o.controls.el.addClass("bx-has-pager").append(o.pagerEl),m()),o.pagerEl.delegate("a","click",k)},b=function(){o.controls.next=t(''+o.settings.nextText+""),o.controls.prev=t(''+o.settings.prevText+""),o.controls.next.bind("click",C),o.controls.prev.bind("click",E),o.settings.nextSelector&&t(o.settings.nextSelector).append(o.controls.next),o.settings.prevSelector&&t(o.settings.prevSelector).append(o.controls.prev),o.settings.nextSelector||o.settings.prevSelector||(o.controls.directionEl=t('

'),o.controls.directionEl.append(o.controls.prev).append(o.controls.next),o.controls.el.addClass("bx-has-controls-direction").append(o.controls.directionEl))},w=function(){o.controls.start=t('

'+o.settings.startText+"

"),o.controls.stop=t('

'+o.settings.stopText+"

"),o.controls.autoEl=t('

'),o.controls.autoEl.delegate(".bx-start","click",A),o.controls.autoEl.delegate(".bx-stop","click",P),o.settings.autoControlsCombine?o.controls.autoEl.append(o.controls.start):o.controls.autoEl.append(o.controls.start).append(o.controls.stop),o.settings.autoControlsSelector?t(o.settings.autoControlsSelector).html(o.controls.autoEl):o.controls.el.addClass("bx-has-controls-auto").append(o.controls.autoEl),M(o.settings.autoStart?"stop":"start")},T=function(){o.children.each(function(){var e=t(this).find("img:first").attr("title");void 0!=e&&t(this).append('

'+e+"

")})},C=function(t){o.settings.auto&&r.stopAuto(),r.goToNextSlide(),t.preventDefault()},E=function(t){o.settings.auto&&r.stopAuto(),r.goToPrevSlide(),t.preventDefault()},A=function(t){r.startAuto(),t.preventDefault()},P=function(t){r.stopAuto(),t.preventDefault()},k=function(e){o.settings.auto&&r.stopAuto();var i=t(e.currentTarget),n=parseInt(i.attr("data-slide-index"));n!=o.active.index&&r.goToSlide(n),e.preventDefault()},y=function(e){return"short"==o.settings.pagerType?(o.pagerEl.html(e+1+o.settings.pagerShortSeparator+o.children.length),void 0):(o.pagerEl.find("a").removeClass("active"),o.pagerEl.each(function(i,n){t(n).find("a").eq(e).addClass("active")}),void 0)},z=function(){if(o.settings.infiniteLoop){var t="";0==o.active.index?t=o.children.eq(0).position():o.active.index==v()-1&&o.carousel?t=o.children.eq((v()-1)*p()).position():o.active.index==o.children.length-1&&(t=o.children.eq(o.children.length-1).position()),"horizontal"==o.settings.mode?x(-t.left,"reset",0):"vertical"==o.settings.mode&&x(-t.top,"reset",0)}o.working=!1,o.settings.onSlideAfter(o.children.eq(o.active.index),o.oldIndex,o.active.index)},M=function(t){o.settings.autoControlsCombine?o.controls.autoEl.html(o.controls[t]):(o.controls.autoEl.find("a").removeClass("active"),o.controls.autoEl.find("a:not(.bx-"+t+")").addClass("active"))},q=function(){!o.settings.infiniteLoop&&o.settings.hideControlOnEnd&&(0==o.active.index?(o.controls.prev.addClass("disabled"),o.controls.next.removeClass("disabled")):o.active.index==v()-1?(o.controls.next.addClass("disabled"),o.controls.prev.removeClass("disabled")):(o.controls.prev.removeClass("disabled"),o.controls.next.removeClass("disabled")))},L=function(){o.settings.autoDelay>0?setTimeout(r.startAuto,o.settings.autoDelay):r.startAuto(),o.settings.autoHover&&r.hover(function(){o.interval&&(r.stopAuto(!0),o.autoPaused=!0)},function(){o.autoPaused&&(r.startAuto(!0),o.autoPaused=null)})},D=function(){var e=0;if("next"==o.settings.autoDirection)r.append(o.children.clone().addClass("bx-clone"));else{r.prepend(o.children.clone().addClass("bx-clone"));var i=o.children.first().position();e="horizontal"==o.settings.mode?-i.left:-i.top}x(e,"reset",0),o.settings.pager=!1,o.settings.controls=!1,o.settings.autoControls=!1,o.settings.tickerHover&&!o.usingCSS&&o.viewport.hover(function(){r.stop()},function(){var e=0;o.children.each(function(){e+="horizontal"==o.settings.mode?t(this).outerWidth(!0):t(this).outerHeight(!0)});var i=o.settings.speed/e,n="horizontal"==o.settings.mode?"left":"top",s=i*(e-Math.abs(parseInt(r.css(n))));I(s)}),I()},I=function(t){speed=t?t:o.settings.speed;var e={left:0,top:0},i={left:0,top:0};"next"==o.settings.autoDirection?e=r.find(".bx-clone").first().position():i=o.children.first().position();var n="horizontal"==o.settings.mode?-e.left:-e.top,s="horizontal"==o.settings.mode?-i.left:-i.top,a={resetValue:s};x(n,"ticker",speed,a)},H=function(){o.touch={start:{x:0,y:0},end:{x:0,y:0}},o.viewport.bind("touchstart",W)},W=function(t){if(o.working)t.preventDefault();else{o.touch.originalPos=r.position();var e=t.originalEvent;o.touch.start.x=e.changedTouches[0].pageX,o.touch.start.y=e.changedTouches[0].pageY,o.viewport.bind("touchmove",N),o.viewport.bind("touchend",B)}},N=function(t){if(t.preventDefault(),"fade"!=o.settings.mode){var e=t.originalEvent,i=0;if("horizontal"==o.settings.mode){var n=e.changedTouches[0].pageX-o.touch.start.x;i=o.touch.originalPos.left+n}else{var n=e.changedTouches[0].pageY-o.touch.start.y;i=o.touch.originalPos.top+n}x(i,"reset",0)}},B=function(t){o.viewport.unbind("touchmove",N);var e=t.originalEvent,i=0;if(o.touch.end.x=e.changedTouches[0].pageX,o.touch.end.y=e.changedTouches[0].pageY,"fade"==o.settings.mode){var n=Math.abs(o.touch.start.x-o.touch.end.x);n>=o.settings.swipeThreshold&&(o.touch.start.x>o.touch.end.x?r.goToNextSlide():r.goToPrevSlide(),r.stopAuto())}else{var n=0;"horizontal"==o.settings.mode?(n=o.touch.end.x-o.touch.start.x,i=o.touch.originalPos.left):(n=o.touch.end.y-o.touch.start.y,i=o.touch.originalPos.top),!o.settings.infiniteLoop&&(0==o.active.index&&n>0||o.active.last&&0>n)?x(i,"reset",200):Math.abs(n)>=o.settings.swipeThreshold?(0>n?r.goToNextSlide():r.goToPrevSlide(),r.stopAuto()):x(i,"reset",200)}o.viewport.unbind("touchend",B)},O=function(){var e=t(window).width(),i=t(window).height();(a!=e||l!=i)&&(a=e,l=i,o.children.add(r.find(".bx-clone")).width(h()),o.viewport.css("height",g()),o.active.last&&(o.active.index=v()-1),o.active.index>=v()&&(o.active.last=!0),o.settings.pager&&!o.settings.pagerCustom&&(m(),y(o.active.index)),o.settings.ticker||f())};return r.goToSlide=function(e,i){if(!o.working&&o.active.index!=e)if(o.working=!0,o.oldIndex=o.active.index,o.active.index=0>e?v()-1:e>=v()?0:e,o.settings.onSlideBefore(o.children.eq(o.active.index),o.oldIndex,o.active.index),"next"==i?o.settings.onSlideNext(o.children.eq(o.active.index),o.oldIndex,o.active.index):"prev"==i&&o.settings.onSlidePrev(o.children.eq(o.active.index),o.oldIndex,o.active.index),o.active.last=o.active.index>=v()-1,o.settings.pager&&y(o.active.index),o.settings.controls&&q(),"fade"==o.settings.mode)o.settings.adaptiveHeight&&o.viewport.height()!=g()&&o.viewport.animate({height:g()},o.settings.adaptiveHeightSpeed),o.children.filter(":visible").fadeOut(o.settings.speed).css({zIndex:0}),o.children.eq(o.active.index).css("zIndex",51).fadeIn(o.settings.speed,function(){t(this).css("zIndex",50),z()});else{o.settings.adaptiveHeight&&o.viewport.height()!=g()&&o.viewport.animate({height:g()},o.settings.adaptiveHeightSpeed);var n=0,s={left:0,top:0};if(!o.settings.infiniteLoop&&o.carousel&&o.active.last)if("horizontal"==o.settings.mode){var a=o.children.eq(o.children.length-1);s=a.position(),n=o.viewport.width()-a.width()}else{var l=o.children.length-o.settings.minSlides;s=o.children.eq(l).position()}else if(o.carousel&&o.active.last&&"prev"==i){var d=1==o.settings.moveSlides?o.settings.maxSlides-p():(v()-1)*p()-(o.children.length-o.settings.maxSlides),a=r.children(".bx-clone").eq(d);s=a.position()}else if("next"==i&&0==o.active.index)s=r.find(".bx-clone").eq(o.settings.maxSlides).position(),o.active.last=!1;else if(e>=0){var c=e*p();s=o.children.eq(c).position()}var h="horizontal"==o.settings.mode?-(s.left-n):-s.top;x(h,"slide",o.settings.speed)}},r.goToNextSlide=function(){if(o.settings.infiniteLoop||!o.active.last){var t=o.active.index+1;r.goToSlide(t,"next")}},r.goToPrevSlide=function(){if(o.settings.infiniteLoop||0!=o.active.index){var t=o.active.index-1;r.goToSlide(t,"prev")}},r.startAuto=function(t){o.interval||(o.interval=setInterval(function(){"next"==o.settings.autoDirection?r.goToNextSlide():r.goToPrevSlide()},o.settings.pause),o.settings.autoControls&&1!=t&&M("stop"))},r.stopAuto=function(t){o.interval&&(clearInterval(o.interval),o.interval=null,o.settings.autoControls&&1!=t&&M("start"))},r.getCurrentSlide=function(){return o.active.index},r.getSlideCount=function(){return o.children.length},r.destroySlider=function(){o.initialized&&(o.initialized=!1,t(".bx-clone",this).remove(),o.children.removeAttr("style"),this.removeAttr("style").unwrap().unwrap(),o.controls.el&&o.controls.el.remove(),o.controls.next&&o.controls.next.remove(),o.controls.prev&&o.controls.prev.remove(),o.pagerEl&&o.pagerEl.remove(),t(".bx-caption",this).remove(),o.controls.autoEl&&o.controls.autoEl.remove(),clearInterval(o.interval),t(window).unbind("resize",O))},r.reloadSlider=function(t){void 0!=t&&(s=t),r.destroySlider(),d()},d(),this}}})(jQuery),function(t,e){var i="data:image/gif;base64,R0lGODlhAQABAIAAAAAAAP///ywAAAAAAQABAAACAUwAOw==";t.fn.imagesLoaded=function(n){function s(){var e=t(g),i=t(h);a&&(h.length?a.reject(d,e,i):a.resolve(d)),t.isFunction(n)&&n.call(r,d,e,i)}function o(e,n){e.src===i||-1!==t.inArray(e,c)||(c.push(e),n?h.push(e):g.push(e),t.data(e,"imagesLoaded",{isBroken:n,src:e.src}),l&&a.notifyWith(t(e),[n,d,t(g),t(h)]),d.length===c.length&&(setTimeout(s),d.unbind(".imagesLoaded")))}var r=this,a=t.isFunction(t.Deferred)?t.Deferred():0,l=t.isFunction(a.notify),d=r.find("img").add(r.filter("img")),c=[],g=[],h=[];return t.isPlainObject(n)&&t.each(n,function(t,e){"callback"===t?n=e:a&&a[t](e)}),d.length?d.bind("load.imagesLoaded error.imagesLoaded",function(t){o(t.target,"error"===t.type)}).each(function(n,s){var r=s.src,a=t.data(s,"imagesLoaded");a&&a.src===r?o(s,a.isBroken):s.complete&&s.naturalWidth!==e?o(s,0===s.naturalWidth||0===s.naturalHeight):(s.readyState||s.complete)&&(s.src=i,s.src=r)}):s(),a?a.promise(r):r}}(jQuery); + + +/* + Prettify JS +*/ +var q=null;window.PR_SHOULD_USE_CONTINUATION=!0; +(function(){function L(a){function m(a){var f=a.charCodeAt(0);if(f!==92)return f;var b=a.charAt(1);return(f=r[b])?f:"0"<=b&&b<="7"?parseInt(a.substring(1),8):b==="u"||b==="x"?parseInt(a.substring(2),16):a.charCodeAt(1)}function e(a){if(a<32)return(a<16?"\\x0":"\\x")+a.toString(16);a=String.fromCharCode(a);if(a==="\\"||a==="-"||a==="["||a==="]")a="\\"+a;return a}function h(a){for(var f=a.substring(1,a.length-1).match(/\\u[\dA-Fa-f]{4}|\\x[\dA-Fa-f]{2}|\\[0-3][0-7]{0,2}|\\[0-7]{1,2}|\\[\S\s]|[^\\]/g),a= +[],b=[],o=f[0]==="^",c=o?1:0,i=f.length;c122||(d<65||j>90||b.push([Math.max(65,j)|32,Math.min(d,90)|32]),d<97||j>122||b.push([Math.max(97,j)&-33,Math.min(d,122)&-33]))}}b.sort(function(a,f){return a[0]-f[0]||f[1]-a[1]});f=[];j=[NaN,NaN];for(c=0;ci[0]&&(i[1]+1>i[0]&&b.push("-"),b.push(e(i[1])));b.push("]");return b.join("")}function y(a){for(var f=a.source.match(/\[(?:[^\\\]]|\\[\S\s])*]|\\u[\dA-Fa-f]{4}|\\x[\dA-Fa-f]{2}|\\\d+|\\[^\dux]|\(\?[!:=]|[()^]|[^()[\\^]+/g),b=f.length,d=[],c=0,i=0;c=2&&a==="["?f[c]=h(j):a!=="\\"&&(f[c]=j.replace(/[A-Za-z]/g,function(a){a=a.charCodeAt(0);return"["+String.fromCharCode(a&-33,a|32)+"]"}));return f.join("")}for(var t=0,s=!1,l=!1,p=0,d=a.length;p=5&&"lang-"===b.substring(0,5))&&!(o&&typeof o[1]==="string"))c=!1,b="src";c||(r[f]=b)}i=d;d+=f.length;if(c){c=o[1];var j=f.indexOf(c),k=j+c.length;o[2]&&(k=f.length-o[2].length,j=k-c.length);b=b.substring(5);B(l+i,f.substring(0,j),e,p);B(l+i+j,c,C(b,c),p);B(l+i+k,f.substring(k),e,p)}else p.push(l+i,b)}a.e=p}var h={},y;(function(){for(var e=a.concat(m), +l=[],p={},d=0,g=e.length;d=0;)h[n.charAt(k)]=r;r=r[1];n=""+r;p.hasOwnProperty(n)||(l.push(r),p[n]=q)}l.push(/[\S\s]/);y=L(l)})();var t=m.length;return e}function u(a){var m=[],e=[];a.tripleQuotedStrings?m.push(["str",/^(?:'''(?:[^'\\]|\\[\S\s]|''?(?=[^']))*(?:'''|$)|"""(?:[^"\\]|\\[\S\s]|""?(?=[^"]))*(?:"""|$)|'(?:[^'\\]|\\[\S\s])*(?:'|$)|"(?:[^"\\]|\\[\S\s])*(?:"|$))/,q,"'\""]):a.multiLineStrings?m.push(["str",/^(?:'(?:[^'\\]|\\[\S\s])*(?:'|$)|"(?:[^"\\]|\\[\S\s])*(?:"|$)|`(?:[^\\`]|\\[\S\s])*(?:`|$))/, +q,"'\"`"]):m.push(["str",/^(?:'(?:[^\n\r'\\]|\\.)*(?:'|$)|"(?:[^\n\r"\\]|\\.)*(?:"|$))/,q,"\"'"]);a.verbatimStrings&&e.push(["str",/^@"(?:[^"]|"")*(?:"|$)/,q]);var h=a.hashComments;h&&(a.cStyleComments?(h>1?m.push(["com",/^#(?:##(?:[^#]|#(?!##))*(?:###|$)|.*)/,q,"#"]):m.push(["com",/^#(?:(?:define|elif|else|endif|error|ifdef|include|ifndef|line|pragma|undef|warning)\b|[^\n\r]*)/,q,"#"]),e.push(["str",/^<(?:(?:(?:\.\.\/)*|\/?)(?:[\w-]+(?:\/[\w-]+)+)?[\w-]+\.h|[a-z]\w*)>/,q])):m.push(["com",/^#[^\n\r]*/, +q,"#"]));a.cStyleComments&&(e.push(["com",/^\/\/[^\n\r]*/,q]),e.push(["com",/^\/\*[\S\s]*?(?:\*\/|$)/,q]));a.regexLiterals&&e.push(["lang-regex",/^(?:^^\.?|[!+-]|!=|!==|#|%|%=|&|&&|&&=|&=|\(|\*|\*=|\+=|,|-=|->|\/|\/=|:|::|;|<|<<|<<=|<=|=|==|===|>|>=|>>|>>=|>>>|>>>=|[?@[^]|\^=|\^\^|\^\^=|{|\||\|=|\|\||\|\|=|~|break|case|continue|delete|do|else|finally|instanceof|return|throw|try|typeof)\s*(\/(?=[^*/])(?:[^/[\\]|\\[\S\s]|\[(?:[^\\\]]|\\[\S\s])*(?:]|$))+\/)/]);(h=a.types)&&e.push(["typ",h]);a=(""+a.keywords).replace(/^ | $/g, +"");a.length&&e.push(["kwd",RegExp("^(?:"+a.replace(/[\s,]+/g,"|")+")\\b"),q]);m.push(["pln",/^\s+/,q," \r\n\t\xa0"]);e.push(["lit",/^@[$_a-z][\w$@]*/i,q],["typ",/^(?:[@_]?[A-Z]+[a-z][\w$@]*|\w+_t\b)/,q],["pln",/^[$_a-z][\w$@]*/i,q],["lit",/^(?:0x[\da-f]+|(?:\d(?:_\d+)*\d*(?:\.\d*)?|\.\d\+)(?:e[+-]?\d+)?)[a-z]*/i,q,"0123456789"],["pln",/^\\[\S\s]?/,q],["pun",/^.[^\s\w"-$'./@\\`]*/,q]);return x(m,e)}function D(a,m){function e(a){switch(a.nodeType){case 1:if(k.test(a.className))break;if("BR"===a.nodeName)h(a), +a.parentNode&&a.parentNode.removeChild(a);else for(a=a.firstChild;a;a=a.nextSibling)e(a);break;case 3:case 4:if(p){var b=a.nodeValue,d=b.match(t);if(d){var c=b.substring(0,d.index);a.nodeValue=c;(b=b.substring(d.index+d[0].length))&&a.parentNode.insertBefore(s.createTextNode(b),a.nextSibling);h(a);c||a.parentNode.removeChild(a)}}}}function h(a){function b(a,d){var e=d?a.cloneNode(!1):a,f=a.parentNode;if(f){var f=b(f,1),g=a.nextSibling;f.appendChild(e);for(var h=g;h;h=g)g=h.nextSibling,f.appendChild(h)}return e} +for(;!a.nextSibling;)if(a=a.parentNode,!a)return;for(var a=b(a.nextSibling,0),e;(e=a.parentNode)&&e.nodeType===1;)a=e;d.push(a)}var k=/(?:^|\s)nocode(?:\s|$)/,t=/\r\n?|\n/,s=a.ownerDocument,l;a.currentStyle?l=a.currentStyle.whiteSpace:window.getComputedStyle&&(l=s.defaultView.getComputedStyle(a,q).getPropertyValue("white-space"));var p=l&&"pre"===l.substring(0,3);for(l=s.createElement("LI");a.firstChild;)l.appendChild(a.firstChild);for(var d=[l],g=0;g=0;){var h=m[e];A.hasOwnProperty(h)?window.console&&console.warn("cannot override language handler %s",h):A[h]=a}}function C(a,m){if(!a||!A.hasOwnProperty(a))a=/^\s*=o&&(h+=2);e>=c&&(a+=2)}}catch(w){"console"in window&&console.log(w&&w.stack?w.stack:w)}}var v=["break,continue,do,else,for,if,return,while"],w=[[v,"auto,case,char,const,default,double,enum,extern,float,goto,int,long,register,short,signed,sizeof,static,struct,switch,typedef,union,unsigned,void,volatile"], +"catch,class,delete,false,import,new,operator,private,protected,public,this,throw,true,try,typeof"],F=[w,"alignof,align_union,asm,axiom,bool,concept,concept_map,const_cast,constexpr,decltype,dynamic_cast,explicit,export,friend,inline,late_check,mutable,namespace,nullptr,reinterpret_cast,static_assert,static_cast,template,typeid,typename,using,virtual,where"],G=[w,"abstract,boolean,byte,extends,final,finally,implements,import,instanceof,null,native,package,strictfp,super,synchronized,throws,transient"], +H=[G,"as,base,by,checked,decimal,delegate,descending,dynamic,event,fixed,foreach,from,group,implicit,in,interface,internal,into,is,lock,object,out,override,orderby,params,partial,readonly,ref,sbyte,sealed,stackalloc,string,select,uint,ulong,unchecked,unsafe,ushort,var"],w=[w,"debugger,eval,export,function,get,null,set,undefined,var,with,Infinity,NaN"],I=[v,"and,as,assert,class,def,del,elif,except,exec,finally,from,global,import,in,is,lambda,nonlocal,not,or,pass,print,raise,try,with,yield,False,True,None"], +J=[v,"alias,and,begin,case,class,def,defined,elsif,end,ensure,false,in,module,next,nil,not,or,redo,rescue,retry,self,super,then,true,undef,unless,until,when,yield,BEGIN,END"],v=[v,"case,done,elif,esac,eval,fi,function,in,local,set,then,until"],K=/^(DIR|FILE|vector|(de|priority_)?queue|list|stack|(const_)?iterator|(multi)?(set|map)|bitset|u?(int|float)\d*)/,N=/\S/,O=u({keywords:[F,H,w,"caller,delete,die,do,dump,elsif,eval,exit,foreach,for,goto,if,import,last,local,my,next,no,our,print,package,redo,require,sub,undef,unless,until,use,wantarray,while,BEGIN,END"+ +I,J,v],hashComments:!0,cStyleComments:!0,multiLineStrings:!0,regexLiterals:!0}),A={};k(O,["default-code"]);k(x([],[["pln",/^[^]*(?:>|$)/],["com",/^<\!--[\S\s]*?(?:--\>|$)/],["lang-",/^<\?([\S\s]+?)(?:\?>|$)/],["lang-",/^<%([\S\s]+?)(?:%>|$)/],["pun",/^(?:<[%?]|[%?]>)/],["lang-",/^]*>([\S\s]+?)<\/xmp\b[^>]*>/i],["lang-js",/^]*>([\S\s]*?)(<\/script\b[^>]*>)/i],["lang-css",/^]*>([\S\s]*?)(<\/style\b[^>]*>)/i],["lang-in.tag",/^(<\/?[a-z][^<>]*>)/i]]), +["default-markup","htm","html","mxml","xhtml","xml","xsl"]);k(x([["pln",/^\s+/,q," \t\r\n"],["atv",/^(?:"[^"]*"?|'[^']*'?)/,q,"\"'"]],[["tag",/^^<\/?[a-z](?:[\w-.:]*\w)?|\/?>$/i],["atn",/^(?!style[\s=]|on)[a-z](?:[\w:-]*\w)?/i],["lang-uq.val",/^=\s*([^\s"'>]*(?:[^\s"'/>]|\/(?=\s)))/],["pun",/^[/<->]+/],["lang-js",/^on\w+\s*=\s*"([^"]+)"/i],["lang-js",/^on\w+\s*=\s*'([^']+)'/i],["lang-js",/^on\w+\s*=\s*([^\s"'>]+)/i],["lang-css",/^style\s*=\s*"([^"]+)"/i],["lang-css",/^style\s*=\s*'([^']+)'/i],["lang-css", +/^style\s*=\s*([^\s"'>]+)/i]]),["in.tag"]);k(x([],[["atv",/^[\S\s]+/]]),["uq.val"]);k(u({keywords:F,hashComments:!0,cStyleComments:!0,types:K}),["c","cc","cpp","cxx","cyc","m"]);k(u({keywords:"null,true,false"}),["json"]);k(u({keywords:H,hashComments:!0,cStyleComments:!0,verbatimStrings:!0,types:K}),["cs"]);k(u({keywords:G,cStyleComments:!0}),["java"]);k(u({keywords:v,hashComments:!0,multiLineStrings:!0}),["bsh","csh","sh"]);k(u({keywords:I,hashComments:!0,multiLineStrings:!0,tripleQuotedStrings:!0}), +["cv","py"]);k(u({keywords:"caller,delete,die,do,dump,elsif,eval,exit,foreach,for,goto,if,import,last,local,my,next,no,our,print,package,redo,require,sub,undef,unless,until,use,wantarray,while,BEGIN,END",hashComments:!0,multiLineStrings:!0,regexLiterals:!0}),["perl","pl","pm"]);k(u({keywords:J,hashComments:!0,multiLineStrings:!0,regexLiterals:!0}),["rb"]);k(u({keywords:w,cStyleComments:!0,regexLiterals:!0}),["js"]);k(u({keywords:"all,and,by,catch,class,else,extends,false,finally,for,if,in,is,isnt,loop,new,no,not,null,of,off,on,or,return,super,then,true,try,unless,until,when,while,yes", +hashComments:3,cStyleComments:!0,multilineStrings:!0,tripleQuotedStrings:!0,regexLiterals:!0}),["coffee"]);k(x([],[["str",/^[\S\s]+/]]),["regex"]);window.prettyPrintOne=function(a,m,e){var h=document.createElement("PRE");h.innerHTML=a;e&&D(h,e);E({g:m,i:e,h:h});return h.innerHTML};window.prettyPrint=function(a){function m(){for(var e=window.PR_SHOULD_USE_CONTINUATION?l.now()+250:Infinity;p=0){var k=k.match(g),f,b;if(b= +!k){b=n;for(var o=void 0,c=b.firstChild;c;c=c.nextSibling)var i=c.nodeType,o=i===1?o?b:c:i===3?N.test(c.nodeValue)?b:o:o;b=(f=o===b?void 0:o)&&"CODE"===f.tagName}b&&(k=f.className.match(g));k&&(k=k[1]);b=!1;for(o=n.parentNode;o;o=o.parentNode)if((o.tagName==="pre"||o.tagName==="code"||o.tagName==="xmp")&&o.className&&o.className.indexOf("prettyprint")>=0){b=!0;break}b||((b=(b=n.className.match(/\blinenums\b(?::(\d+))?/))?b[1]&&b[1].length?+b[1]:!0:!1)&&D(n,b),d={g:k,h:n,i:b},E(d))}}particle,aside,figcaption,figure,footer,header,hgroup,main,nav,section{display:block}mark{background:#FF0;color:#000}"; +c=d.insertBefore(c.lastChild,d.firstChild);b.hasCSS=!!c}g||t(a,b);return a}var k=l.html5||{},s=/^<|^(?:button|map|select|textarea|object|iframe|option|optgroup)$/i,r=/^(?:a|b|code|div|fieldset|h1|h2|h3|h4|h5|h6|i|label|li|ol|p|q|span|strong|style|table|tbody|td|th|tr|ul)$/i,j,o="_html5shiv",h=0,n={},g;(function(){try{var a=f.createElement("a");a.innerHTML="";j="hidden"in a;var b;if(!(b=1==a.childNodes.length)){f.createElement("a");var c=f.createDocumentFragment();b="undefined"==typeof c.cloneNode|| +"undefined"==typeof c.createDocumentFragment||"undefined"==typeof c.createElement}g=b}catch(d){g=j=!0}})();var e={elements:k.elements||"abbr article aside audio bdi canvas data datalist details figcaption figure footer header hgroup main mark meter nav output progress section summary time video",version:"3.6.2pre",shivCSS:!1!==k.shivCSS,supportsUnknownElements:g,shivMethods:!1!==k.shivMethods,type:"default",shivDocument:q,createElement:p,createDocumentFragment:function(a,b){a||(a=f);if(g)return a.createDocumentFragment(); +for(var b=b||i(a),c=b.frag.cloneNode(),d=0,e=m(),h=e.length;d ... ) ) +;; 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 lost 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,11 +7,12 @@ ;; 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) +(use srfi-1 data-structures 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:)) @@ -29,45 +30,80 @@ ;; (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 (and (string? val)(string? key)) - (handle-exceptions - exn - (debug:print-error 0 *default-log-port* "bad value for setenv, key=" key ", value=" val) - (setenv key val)) - (debug:print-error 0 *default-log-port* "bad value for setenv, key=" key ", value=" val))) + (if (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) + (string? key)) + (handle-exceptions + exn + (debug:print-error 0 *default-log-port* "bad value for setenv, key=" key ", value=" val) + (setenv key val)) + (debug:print-error 0 *default-log-port* "bad value for setenv, key=" key ", value=" val)))) (define home (getenv "HOME")) (define user (getenv "USER")) -;; GLOBAL GLETCHES + +;; returns list of fd count, socket count +(define (get-file-descriptor-count #!key (pid (current-process-id ))) + (list + (length (glob (conc "/proc/" pid "/fd/*"))) + (length (filter identity (map socket? (glob (conc "/proc/" pid "/fd/*"))))) + ) +) + + +;; GLOBALS ;; CONTEXTS (defstruct cxt (taskdb #f) (cmutex (make-mutex))) -(define *contexts* (make-hash-table)) -(define *context-mutex* (make-mutex)) - -;; safe method for accessing a context given a toppath -;; -(define (common:with-cxt toppath proc) - (mutex-lock! *context-mutex*) - (let ((cxt (hash-table-ref/default *contexts* toppath #f))) - (if (not cxt) - (set! cxt (let ((x (make-cxt)))(hash-table-set! *contexts* toppath x) x))) - (let ((cxt-mutex (cxt-mutex cxt))) - (mutex-unlock! *context-mutex*) - (mutex-lock! cxt-mutex) - (let ((res (proc cxt))) - (mutex-unlock! cxt-mutex) - res)))) - +;; (define *contexts* (make-hash-table)) +;; (define *context-mutex* (make-mutex)) + +;; ;; safe method for accessing a context given a toppath +;; ;; +;; (define (common:with-cxt toppath proc) +;; (mutex-lock! *context-mutex*) +;; (let ((cxt (hash-table-ref/default *contexts* toppath #f))) +;; (if (not cxt) +;; (set! cxt (let ((x (make-cxt)))(hash-table-set! *contexts* toppath x) x))) +;; (let ((cxt-mutex (cxt-mutex cxt))) +;; (mutex-unlock! *context-mutex*) +;; (mutex-lock! cxt-mutex) +;; (let ((res (proc cxt))) +;; (mutex-unlock! cxt-mutex) +;; res)))) + +;; A hash table that can be accessed by #{scheme ...} calls in +;; config files. Allows communicating between confgs +;; +(define *user-hash-data* (make-hash-table)) + (define *db-keys* #f) (define *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 @@ -76,11 +112,11 @@ (define *already-seen-runconfig-info* #f) (define *test-meta-updated* (make-hash-table)) (define *globalexitstatus* 0) ;; attempt to work around possible thread issues (define *passnum* 0) ;; when running track calls to run-tests or similar -(define *alt-log-file* #f) ;; used by -log +;; (define *alt-log-file* #f) ;; used by -log (define *common:denoise* (make-hash-table)) ;; for low noise printing (define *default-log-port* (current-error-port)) (define *time-zero* (current-seconds)) ;; for the watchdog ;; DATABASE @@ -101,28 +137,31 @@ (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 *max-cache-size* 0) (define *logged-in-clients* (make-hash-table)) (define *server-id* #f) -(define *server-info* #f) +(define *server-info* #f) ;; good candidate for easily convert to non-global (define *time-to-exit* #f) (define *server-run* #t) (define *run-id* #f) (define *server-kind-run* (make-hash-table)) (define *home-host* #f) -(define *total-non-write-delay* 0) +;; (define *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 @@ -139,17 +178,23 @@ (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 + (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 (or (server:get-timeout) 100))) ;; default to 100 seconds + (server-timeout (server:expiration-timeout)) + (force-server #f) + (ro-mode #f) + (ro-mode-checked #f)) ;; flag that indicates we have checked for ro-mode ;; launching and hosts (defstruct host (reachable #f) (last-update 0) @@ -212,28 +257,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 @@ -253,11 +310,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))) @@ -268,38 +325,54 @@ (delete-file fullname))))))) '() "logs")) ;; Force a megatest cleanup-db if version is changed and skip-version-check not specified +;; Do NOT check if not on homehost! ;; (define (common:exit-on-version-changed) - (if (common:version-changed?) - (if (common:on-homehost?) - (let ((mtconf (conc (get-environment-variable "MT_RUN_AREA_HOME") "/megatest.config")) - (dbstruct (db:setup))) + (if (common:on-homehost?) + (if (common:api-changed?) + (let* ((mtconf (conc (get-environment-variable "MT_RUN_AREA_HOME") "/megatest.config")) + (dbfile (conc (get-environment-variable "MT_RUN_AREA_HOME") "/megatest.db")) + (read-only (not (file-write-access? dbfile))) + (dbstruct (db:setup #t))) (debug:print 0 *default-log-port* "WARNING: Version mismatch!\n" " expected: " (common:version-signature) "\n" " got: " (common:get-last-run-version)) - (if (and (file-exists? mtconf) - (eq? (current-user-id)(file-owner mtconf))) ;; safe to run -cleanup-db - (begin - (debug:print 0 *default-log-port* " I see you are the owner of megatest.config, attempting to cleanup and reset to new version") - (handle-exceptions - exn - (begin - (debug:print 0 *default-log-port* "Failed to switch versions.") - (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) - (print-call-chain (current-error-port)) - (exit 1)) - (common:cleanup-db dbstruct))) - (begin - (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))))) + (cond + ((get-environment-variable "MT_SKIP_DB_MIGRATE") #t) + ((and (common:file-exists? mtconf) (common:file-exists? dbfile) (not read-only) + (eq? (current-user-id)(file-owner mtconf))) ;; safe to run -cleanup-db + (debug:print 0 *default-log-port* " I see you are the owner of megatest.config, attempting to cleanup and reset to new version") + (handle-exceptions + exn + (begin + (debug:print 0 *default-log-port* "Failed to switch versions.") + (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) + (print-call-chain (current-error-port)) + (exit 1)) + (common:cleanup-db dbstruct))) + ((not (common:file-exists? mtconf)) + (debug:print 0 *default-log-port* " megatest.config does not exist in this area. Cannot proceed with megatest version migration.") + (exit 1)) + ((not (common:file-exists? dbfile)) + (debug:print 0 *default-log-port* " megatest.db does not exist in this area. Cannot proceed with megatest version migration.") + (exit 1)) + ((not (eq? (current-user-id)(file-owner mtconf))) + (debug:print 0 *default-log-port* " You do not own megatest.db in this area. Cannot proceed with megatest version migration.") + (exit 1)) + (read-only + (debug:print 0 *default-log-port* " You have read-only access to this area. Cannot proceed with megatest version migration.") + (exit 1)) + (else + (debug:print 0 *default-log-port* " to switch versions you can run: \"megatest -cleanup-db\"") + (exit 1))))))) +;; (begin +;; (debug:print 0 *default-log-port* "ERROR: cannot migrate version unless on homehost. Exiting.") +;; (exit 1)))) ;;====================================================================== ;; S P A R S E A R R A Y S ;;====================================================================== @@ -392,35 +465,53 @@ ;; dot-locking egg seems not to work, using this for now ;; if lock is older than expire-time then remove it and try again ;; to get the lock ;; (define (common:simple-file-lock fname #!key (expire-time 300)) - (if (file-exists? fname) - (if (> (- (current-seconds)(file-modification-time fname)) expire-time) - (begin - (delete-file* fname) - (common:simple-file-lock fname expire-time: expire-time)) - #f) - (let ((key-string (conc (get-host-name) "-" (current-process-id)))) - (with-output-to-file fname - (lambda () - (print key-string))) - (thread-sleep! 0.25) - (if (file-exists? fname) - (with-input-from-file fname - (lambda () - (equal? key-string (read-line)))) - #f)))) - + (handle-exceptions + exn + #f ;; don't really care what went wrong right now. NOTE: I have not seen this one actually fail. + (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) + (let ((key-string (conc (get-host-name) "-" (current-process-id)))) + (with-output-to-file fname + (lambda () + (print key-string))) + (thread-sleep! 0.25) + (if (common:file-exists? fname) + (with-input-from-file fname + (lambda () + (equal? key-string (read-line)))) + #f))))) + +(define (common:simple-file-lock-and-wait fname #!key (expire-time 300)) + (let ((end-time (+ expire-time (current-seconds)))) + (let loop ((got-lock (common:simple-file-lock fname expire-time: expire-time))) + (if got-lock + #t + (if (> end-time (current-seconds)) + (begin + (thread-sleep! 3) + (loop (common:simple-file-lock fname expire-time: expire-time))) + #f))))) + (define (common:simple-file-release-lock fname) - (delete-file* fname)) + (handle-exceptions + exn + #f ;; I don't really care why this failed (at least for now) + (delete-file* fname))) ;;====================================================================== ;; S T A T E S A N D S T A T U S E S ;;====================================================================== -(define *common:std-states* +;; 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") @@ -428,30 +519,33 @@ (6 "LAUNCHED") (7 "REMOTEHOSTSTART") (8 "RUNNING") )) +;; BBnote: *common:std-statuses* dashboard filter control and test control status buttons defined here; used in set-fields-panel and dboard:make-controls (define *common:std-statuses* '(;; (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 "ABORT"))) (define *common:ended-states* ;; states which indicate the test is stopped and will not proceed '("COMPLETED" "ARCHIVED" "KILLED" "KILLREQ" "STUCK" "INCOMPLETE")) (define *common:badly-ended-states* ;; these roll up as CHECK, i.e. results need to be checked '("KILLED" "KILLREQ" "STUCK" "INCOMPLETE" "DEAD")) +;; 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 @@ -533,28 +627,43 @@ (define (assoc/default key lst . default) (let ((res (assoc key lst))) (if res (cadr res)(if (null? default) #f (car default))))) (define (common:get-testsuite-name) - (or (configf:lookup *configdat* "setup" "testsuite" ) - (if *toppath* + (or (configf:lookup *configdat* "setup" "area-name") ;; megatest is a flexible tool, testsuite is too limiting a description. + (configf:lookup *configdat* "setup" "testsuite" ) + (getenv "MT_TESTSUITE_NAME") + (if (string? *toppath* ) (pathname-file *toppath*) - (pathname-file (current-directory))))) + #f))) ;; (pathname-file (current-directory))))) -(define (common:get-db-tmp-area) +(define common:get-area-name common:get-testsuite-name) + +(define (common:get-db-tmp-area . junk) (if *db-cache-path* *db-cache-path* - (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*)) +(define (common:get-signature str) + (message-digest-string (md5-primitive) str)) + ;;====================================================================== ;; E X I T H A N D L I N G ;;====================================================================== (define (common:run-sync?) @@ -563,100 +672,69 @@ ;; (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)) ;; currently the primary job of the watchdog is to run the sync back to megatest.db from the db in /tmp ;; if we are on the homehost and we are a server (by definition we are on the homehost if we are a server) ;; -(define (common:watchdog) + + +(define (common:readonly-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 0 *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)))) - ;; (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)) - ;;(BB> "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))))))) + (debug:print-info 13 *default-log-port* "common:readonly-watchdog entered.") + ;; sync megatest.db to /tmp/.../megatst.db + (let* ((sync-cool-off-duration 3) + (golden-mtdb (dbr:dbstruct-mtdb dbstruct)) + (golden-mtpath (db:dbdat-get-path golden-mtdb)) + (tmp-mtdb (dbr:dbstruct-tmpdb dbstruct)) + (tmp-mtpath (db:dbdat-get-path tmp-mtdb))) + (debug:print-info 0 *default-log-port* "Read-only periodic sync thread started.") + (let loop ((last-sync-time 0)) + (debug:print-info 13 *default-log-port* "loop top tmp-mtpath="tmp-mtpath" golden-mtpath="golden-mtpath) + (let* ((duration-since-last-sync (- (current-seconds) last-sync-time))) + (debug:print-info 13 *default-log-port* "duration-since-last-sync="duration-since-last-sync) + (if (and (not *time-to-exit*) + (< duration-since-last-sync sync-cool-off-duration)) + (thread-sleep! (- sync-cool-off-duration duration-since-last-sync))) + (if (not *time-to-exit*) + (let ((golden-mtdb-mtime (file-modification-time golden-mtpath)) + (tmp-mtdb-mtime (file-modification-time tmp-mtpath))) + (if (> golden-mtdb-mtime tmp-mtdb-mtime) + (if (< golden-mtdb-mtime (- (current-seconds) 3)) ;; file has NOT been touched in past three seconds, this way multiple servers won't fight to sync back + (let ((res (db:multi-db-sync dbstruct 'old2new))) + (debug:print-info 13 *default-log-port* "rosync called, " res " records transferred.")))) + (loop (current-seconds))) + #t))) + (debug:print-info 0 *default-log-port* "Exiting readonly-watchdog timer, *time-to-exit* = " *time-to-exit*" pid="(current-process-id)" mtpath="golden-mtpath))) + +;; TODO: for multiple areas, we will have multiple watchdogs; and multiple threads to manage +(define (common:watchdog) + (debug:print-info 13 *default-log-port* "common:watchdog entered.") + (if (launch:setup) + (if (common:on-homehost?) + (let ((dbstruct (db:setup #t))) + (debug:print-info 13 *default-log-port* "after db:setup with dbstruct=" dbstruct) + (cond + ((dbr:dbstruct-read-only dbstruct) + (debug:print-info 13 *default-log-port* "loading read-only watchdog") + (common:readonly-watchdog dbstruct)) + (else + (debug:print-info 13 *default-log-port* "loading writable-watchdog.") + (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)) - ;;(BB> "std-exit-procedure called; *time-to-exit*="*time-to-exit*) + ;;(debug:print-info 13 *default-log-port* "std-exit-procedure called; *time-to-exit*="*time-to-exit*) (let ((no-hurry (if *time-to-exit* ;; hurry up #f (begin (set! *time-to-exit* #t) #t)))) @@ -671,14 +749,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...") @@ -699,11 +778,11 @@ 0) (define (std-signal-handler signum) ;; (signal-mask! signum) (set! *time-to-exit* #t) - ;;(BB> "got signal "signum) + ;;(debug:print-info 13 *default-log-port* "got signal "signum) (debug:print-error 0 *default-log-port* "Received signal " signum " exiting promptly") ;; (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 @@ -712,19 +791,10 @@ ;;====================================================================== ;; M I S C U T I L S ;;====================================================================== -;; one-of args defined -(define (args-defined? . param) - (let ((res #f)) - (for-each - (lambda (arg) - (if (args:get-arg arg)(set! res #t))) - param) - res)) - ;; convert stuff to a number if possible (define (any->number val) (cond ((number? val) val) ((string? val) (string->number val)) @@ -747,25 +817,10 @@ (set! res #t)))) (string-split patts ",")) res) #t)) -;; (map print (map car (hash-table->alist (read-config "runconfigs.config" #f #t)))) -(define (common:get-runconfig-targets #!key (configf #f)) - (let ((targs (sort (map car (hash-table->alist - (or configf - (read-config (conc *toppath* "/runconfigs.config") - #f #t) - (make-hash-table)))) - string curmod last-mod) + (list curmod fname) + res))) + '(0 "n/a") + all-files))) + +;; use bash to expand a glob. Does NOT handle paths with spaces! +;; +(define (common:bash-glob instr) + (string-split + (with-input-from-pipe + (conc "/bin/bash -c \"echo " instr "\"") + read-line))) ;;====================================================================== ;; T A R G E T S , S T A T E , S T A T U S , ;; R U N N A M E A N D T E S T P A T T ;;====================================================================== + +;; (map print (map car (hash-table->alist (read-config "runconfigs.config" #f #t)))) +;; +(define (common:get-runconfig-targets #!key (configf #f)) + (let ((targs (sort (map car (hash-table->alist + (or configf ;; NOTE: There is no value in using runconfig:read here. + (read-config (conc *toppath* "/runconfigs.config") + #f #t) + (make-hash-table)))) + string trynum 0) + (let ((delay-time (* (- 5 trynum) 5))) + (mutex-unlock! *homehost-mutex*) + (debug:print 0 *default-log-port* "ERROR: Failed to read .homehost file, delaying " delay-time " seconds and trying again, message: " ((condition-property-accessor 'exn 'message) exn)) + (thread-sleep! delay-time) + (common:get-homehost trynum: (- trynum 1))) + (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 (common:file-exists? hhf) + (with-input-from-file hhf read-line) + (if (file-write-access? *toppath*) + (begin + (with-output-to-file hhf + (lambda () + (print bestadrs))) + (begin + (mutex-unlock! *homehost-mutex*) + (car (common:get-homehost)))) + #f)))))) (at-home (or (equal? homehost currhost) (equal? homehost bestadrs)))) (set! *home-host* (cons homehost at-home)) (mutex-unlock! *homehost-mutex*) *home-host*)))) @@ -933,10 +1101,47 @@ (define (common:on-homehost?) (let ((hh (common:get-homehost))) (if hh (cdr hh) #f))) + +;; do we honor the caches of the config files? +;; +(define (common:use-cache?) + (let ((res #t)) ;; priority by order of evaluation + (if *configdat* ;; sillyness here. can't use setup/use-cache to know if we can use the cached files! + (if (equal? (configf:lookup *configdat* "setup" "use-cache") "no") + (set! res #f) + (if (equal? (configf:lookup *configdat* "setup" "use-cache") "yes") + (set! res #t)))) + (if (args:get-arg "-no-cache")(set! res #f)) ;; overrides setting in "setup" + (if (getenv "MT_USE_CACHE") + (if (equal? (getenv "MT_USE_CACHE") "yes") + (set! res #t) + (if (equal? (getenv "MT_USE_CACHE") "no") + (set! res #f)))) ;; overrides -no-cache switch + res)) + +;; force use of server? +;; +(define (common:force-server?) + (let* ((force-setting (configf:lookup *configdat* "server" "force")) + (force-type (if force-setting (string->symbol force-setting) #f)) + (force-result (case force-type + ((#f) #f) + ((always) #t) + ((test) (if (args:get-arg "-execute") ;; we are in a test + #t + #f)) + (else + (debug:print 0 *default-log-port* "ERROR: Bad server force setting " force-setting ", forcing server.") + #t)))) ;; default to requiring server + (if force-result + (begin + (debug:print-info 0 *default-log-port* "forcing use of server, force setting is \"" force-setting "\".") + #t) + #f))) ;;====================================================================== ;; M I S C L I S T S ;;====================================================================== @@ -1100,23 +1305,23 @@ ;; lazy-safe get file mod time. on any error (file not existing etc.) return 0 ;; (define (common:lazy-modification-time fpath) (handle-exceptions - exn - 0 - (file-modification-time fpath))) + exn + 0 + (file-modification-time fpath))) ;; find timestamp of newest file associated with a sqlite db file (define (common:lazy-sqlite-db-modification-time fpath) (let* ((glob-list (handle-exceptions - exn - '("/no/such/file") - (glob (conc fpath "*")))) + exn + `(,(conc "/no/such/file, message: " ((condition-property-accessor 'exn 'message) exn))) + (glob (conc fpath "*")))) (file-list (if (eq? 0 (length glob-list)) - '("/no/such/file") - glob-list))) + '("/no/such/file") + glob-list))) (apply max (map common:lazy-modification-time file-list)))) @@ -1305,30 +1510,35 @@ (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)) (let* ((loadavg (common:get-cpu-load remote-host)) (first (car loadavg)) (next (cadr loadavg)) (adjload (* maxload numcpus)) (loadjmp (- first next))) (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 "")) + (debug:print-info 0 *default-log-port* "server start delayed " waitdelay " 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! waitdelay) - (common:wait-for-cpuload maxload numcpus waitdelay count: (- count 1))) + (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)))))) + (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))) @@ -1344,13 +1554,13 @@ proc) (with-input-from-file "/proc/cpuinfo" proc)))) ;; 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)) @@ -1479,28 +1689,37 @@ #f))) ;; #f means no disk candidate found ;;====================================================================== ;; E N V I R O N M E N T V A R S ;;====================================================================== +(define (bb-check-path #!key (msg "check-path: ")) + (let ((path (or (get-environment-variable "PATH") "none"))) + (debug:print-info 0 *default-log-port* (conc msg" : $PATH="path)) + (if (string-match "^.*/isoenv-core/.*" path) + (debug:print-error 0 *default-log-port* (conc msg" : !!ISOENV PRESENT!!")) ;; remove for prod + (debug:print-info 1 *default-log-port* (conc msg" : **no isoenv present**"))))) + (define (save-environment-as-files fname #!key (ignorevars (list "USER" "HOME" "DISPLAY" "LS_COLORS" "XKEYSYMDB" "EDITOR" "MAKEFLAGS" "MAKEF" "MAKEOVERRIDES"))) + ;;(bb-check-path msg: "save-environment-as-files entry") (let ((envvars (get-environment-variables)) (whitesp (regexp "[^a-zA-Z0-9_\\-:,.\\/%$]")) (mungeval (lambda (val) (cond ((eq? val #t) "") ;; convert #t to empty string ((eq? val #f) #f) ;; convert #f to itself (still thinking about this one (else val))))) - (with-output-to-file (conc fname ".csh") + (with-output-to-file (conc fname ".csh") (lambda () (for-each (lambda (keyval) (let* ((key (car keyval)) (val (cdr keyval)) (delim (if (string-search whitesp val) "\"" ""))) - (print (if (member key ignorevars) + (print (if (or (member key ignorevars) + (string-search whitesp key)) "# setenv " "setenv ") key " " delim (mungeval val) delim))) envvars))) (with-output-to-file (conc fname ".sh") @@ -1509,11 +1728,13 @@ (let* ((key (car keyval)) (val (cdr keyval)) (delim (if (string-search whitesp val) "\"" ""))) - (print (if (member key ignorevars) + (print (if (or (member key ignorevars) + (string-search whitesp key) + (string-search ":" key)) ;; internal only values to be skipped. "# export " "export ") key "=" delim (mungeval val) delim))) envvars))))) @@ -1526,11 +1747,11 @@ (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) '())) @@ -1638,10 +1859,15 @@ ((4 5 6) 2) ((7 8 9) 3) ((10 11 12) 4) (else #f))) +;; basic ISO8601 format (e.g. "2017-02-28 06:02:54") date time => Unix epoch +;; +(define (common:date-time->seconds datetime) + (local-time->seconds (string->time datetime "%Y-%m-%d %H:%M:%S"))) + ;; given span of seconds tstart to tend ;; find start time to mark and mark delta ;; (define (common:find-start-mark-and-mark-delta tstart tend) (let* ((deltat (- (max tend (+ tend 10)) tstart)) ;; can't handle runs of less than 4 seconds. Pad it to 10 seconds ... @@ -1671,12 +1897,175 @@ (list 8 6 5 2 1))) '(5 10 15 20 30 40 50 500)) (if values (apply values result) (values 0 day 1 0 'd)))) + +;; given x y lim return the cron expansion +;; +(define (common:expand-cron-slash x y lim) + (let loop ((curr x) + (res `())) + (if (< curr lim) + (loop (+ curr y) (cons curr res)) + (reverse res)))) + +;; expand a complex cron string to a list of cron strings +;; +;; x/y => x, x+y, x+2y, x+3y while x+Ny a, b ,c +;; +;; NOTE: with flatten a lot of the crud below can be factored down. +;; +(define (common:cron-expand cron-str) + (if (list? cron-str) + (flatten + (fold (lambda (x res) + (if (list? x) + (let ((newres (map common:cron-expand x))) + (append x newres)) + (cons x res))) + '() + cron-str)) ;; (map common:cron-expand cron-str)) + (let ((cron-items (string-split cron-str)) + (slash-rx (regexp "(\\d+)/(\\d+)")) + (comma-rx (regexp ".*,.*")) + (max-vals '((min . 60) + (hour . 24) + (dayofmonth . 28) ;;; BUG!!!! This will be a bug for some combinations + (month . 12) + (dayofweek . 7)))) + (if (< (length cron-items) 5) ;; bad spec + cron-str ;; `(,cron-str) ;; just return the string, something downstream will fix it + (let loop ((hed (car cron-items)) + (tal (cdr cron-items)) + (type 'min) + (type-tal '(hour dayofmonth month dayofweek)) + (res '())) + (regex-case + hed + (slash-rx ( _ base incr ) (let* ((basen (string->number base)) + (incrn (string->number incr)) + (expanded-vals (common:expand-cron-slash basen incrn (alist-ref type max-vals))) + (new-list-crons (fold (lambda (x myres) + (cons (conc (if (null? res) + "" + (conc (string-intersperse res " ") " ")) + x " " (string-intersperse tal " ")) + myres)) + '() expanded-vals))) + ;; (print "new-list-crons: " new-list-crons) + ;; (fold (lambda (x res) + ;; (if (list? x) + ;; (let ((newres (map common:cron-expand x))) + ;; (append x newres)) + ;; (cons x res))) + ;; '() + (flatten (map common:cron-expand new-list-crons)))) + ;; (map common:cron-expand (map common:cron-expand new-list-crons)))) + (else (if (null? tal) + cron-str + (loop (car tal)(cdr tal)(car type-tal)(cdr type-tal)(append res (list hed))))))))))) + - +;; given a cron string and the last time event was processed return #t to run or #f to not run +;; +;; min hour dayofmonth month dayofweek +;; 0-59 0-23 1-31 1-12 0-6 ### NOTE: dayofweek does not include 7 +;; +;; #t => yes, run the job +;; #f => no, do not run the job +;; +(define (common:cron-event cron-str now-seconds-in last-done) ;; ref-seconds = #f is NOW. + (let* ((cron-items (map string->number (string-split cron-str))) + (now-seconds (or now-seconds-in (current-seconds))) + (now-time (seconds->local-time now-seconds)) + (last-done-time (seconds->local-time last-done)) + (all-times (make-hash-table))) + ;; (print "cron-items: " cron-items "(length cron-items): " (length cron-items)) + (if (not (eq? (length cron-items) 5)) ;; don't even try to figure out junk strings + #f + (match-let ((( cmin chour cdayofmonth cmonth cdayofweek) + cron-items) + ;; 0 1 2 3 4 5 6 + ((nsec nmin nhour ndayofmonth nmonth nyr ndayofweek n7 n8 n9) + (vector->list now-time)) + ((lsec lmin lhour ldayofmonth lmonth lyr ldayofweek l7 l8 l9) + (vector->list last-done-time))) + ;; create all possible time slots + ;; remove invalid slots due to (for example) day of week + ;; get the start and end entries for the ref-seconds (current) time + ;; if last-done > ref-seconds => this is an ERROR! + ;; does the last-done time fall in the legit region? + ;; yes => #f do not run again this command + ;; no => #t ok to run the command + (for-each ;; month + (lambda (month) + (for-each ;; dayofmonth + (lambda (dom) + (for-each + (lambda (hr) ;; hour + (for-each + (lambda (minute) ;; minute + (let ((copy-now (apply vector (vector->list now-time)))) + (vector-set! copy-now 0 0) ;; force seconds to zero + (vector-set! copy-now 1 minute) + (vector-set! copy-now 2 hr) + (vector-set! copy-now 3 dom) ;; dom is already corrected for zero referenced + (vector-set! copy-now 4 month) + (let* ((copy-now-secs (local-time->seconds copy-now)) + (new-copy (seconds->local-time copy-now-secs))) ;; remake the time vector + (if (or (not cdayofweek) + (equal? (vector-ref new-copy 6) + cdayofweek)) ;; if the day is specified and a match OR if the day is NOT specified + (if (or (not cdayofmonth) + (equal? (vector-ref new-copy 3) + (+ 1 cdayofmonth))) ;; if the month is specified and a match OR if the month is NOT specified + (hash-table-set! all-times copy-now-secs new-copy)))))) + (if cmin + `(,cmin) ;; if given cmin, have to use it + (list (- nmin 1) nmin (+ nmin 1))))) ;; minute + (if chour + `(,chour) + (list (- nhour 1) nhour (+ nhour 1))))) ;; hour + (if cdayofmonth + `(,cdayofmonth) + (list (- ndayofmonth 1) ndayofmonth (+ ndayofmonth 1))))) + (if cmonth + `(,cmonth) + (list (- nmonth 1) nmonth (+ nmonth 1)))) + (let ((before #f) + (is-in #f)) + (for-each + (lambda (moment) + (if (and before + (<= before now-seconds) + (>= moment now-seconds)) + (begin + ;; (print) + ;; (print "Before: " (time->string (seconds->local-time before))) + ;; (print "Now: " (time->string (seconds->local-time now-seconds))) + ;; (print "After: " (time->string (seconds->local-time moment))) + ;; (print "Last: " (time->string (seconds->local-time last-done))) + (if (< last-done before) + (set! is-in before)) + )) + (set! before moment)) + (sort (hash-table-keys all-times) <)) + is-in))))) + +(define (common:extended-cron cron-str now-seconds-in last-done) + (let ((expanded-cron (common:cron-expand cron-str))) + (if (string? expanded-cron) + (common:cron-event expanded-cron now-seconds-in last-done) + (let loop ((hed (car expanded-cron)) + (tal (cdr expanded-cron))) + (if (common:cron-event hed now-seconds-in last-done) + #t + (if (null? tal) + #f + (loop (car tal)(cdr tal)))))))) ;;====================================================================== ;; C O L O R S ;;====================================================================== @@ -1710,10 +2099,50 @@ (number->string x 16)) (map string->number (string-split instr))) "/")) +;;====================================================================== +;; L O C K I N G M E C H A N I S M S +;;====================================================================== + +;; faux-lock is deprecated. Please use simple-lock below +;; +(define (common:faux-lock keyname #!key (wait-time 8)(allow-lock-steal #t)) + (if (rmt:no-sync-get/default keyname #f) ;; do not be tempted to compare to pid. locking is a one-shot action, if already locked for this pid it doesn't actually count + (if (> wait-time 0) + (begin + (thread-sleep! 1) + (if (eq? wait-time 1) ;; only one second left, steal the lock + (begin + (debug:print-info 0 *default-log-port* "stealing lock for " keyname) + (common:faux-unlock keyname force: #t))) + (common:faux-lock keyname wait-time: (- wait-time 1))) + #f) + (begin + (rmt:no-sync-set keyname (conc (current-process-id))) + (equal? (conc (current-process-id)) (conc (rmt:no-sync-get/default keyname #f)))))) + +(define (common:faux-unlock keyname #!key (force #f)) + (if (or force (equal? (conc (current-process-id)) (conc (rmt:no-sync-get/default keyname #f)))) + (begin + (if (rmt:no-sync-get/default keyname #f) (rmt:no-sync-del! keyname)) + #t) + #f)) + +;; simple lock. improve and converge on this one. +;; +(define (common:simple-lock keyname) + (rmt:no-sync-get-lock keyname)) + +;;====================================================================== +;; +;;====================================================================== + +(define (common:in-running-test?) + (and (args:get-arg "-execute") (get-environment-variable "MT_CMDINFO"))) + (define (common:get-color-from-status status) (cond ((equal? status "PASS") "green") ((equal? status "FAIL") "red") ((equal? status "WARN") "orange") @@ -1872,12 +2301,12 @@ ;; (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)) Index: common_records.scm ================================================================== --- common_records.scm +++ common_records.scm @@ -26,13 +26,27 @@ (define-syntax define-simple-syntax (syntax-rules () ((_ (name arg ...) body ...) (define-syntax name (syntax-rules () ((name arg ...) (begin body ...))))))) +;; (define-syntax common:handle-exceptions +;; (syntax-rules () +;; ((_ exn-in errstmt ...)(handle-exceptions exn-in errstmt ...)))) + +(define-syntax common:debug-handle-exceptions + (syntax-rules () + ((_ debug exn errstmt body ...) + (if debug + (begin body ...) + (handle-exceptions exn errstmt body ...))))) + (define-syntax common:handle-exceptions (syntax-rules () - ((_ exn-in errstmt ...)(handle-exceptions exn-in errstmt ...)))) + ((_ exn errstmt body ...) + (begin body ...)))) + +;; (define handle-exceptions common:handle-exceptions) ;; iup callbacks are not dumping the stack, this is a work-around ;; (define-simple-syntax (debug:catch-and-dump proc procname) (handle-exceptions @@ -97,11 +111,11 @@ (list? n)) (not (null? (lset-intersection! eq? *verbosity* n)))) ((and (number? *verbosity*) (list? n)) (member *verbosity* n)))) - + (define (debug:setup) (let ((debugstr (or (args:get-arg "-debug") (getenv "MT_DEBUG_MODE")))) (set! *verbosity* (debug:calc-verbosity debugstr)) (debug:check-verbosity *verbosity* debugstr) @@ -124,19 +138,24 @@ ;; Brandon's debug printer shortcut (indulge me :) (define *BB-process-starttime* (current-milliseconds)) (define (BB> . in-args) (let* ((stack (get-call-chain)) - (location #f)) + (location "??")) (for-each (lambda (frame) (let* ((this-loc (vector-ref frame 0)) - (this-func (cadr (string-split this-loc " ")))) + (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 ((dp-args + (append + (list 0 *default-log-port* + (conc location "@"(/ (- (current-milliseconds) *BB-process-starttime*) 1000)" ") ) + in-args))) (apply debug:print dp-args)))) (define *BBpp_custom_expanders_list* (make-hash-table)) @@ -185,11 +204,11 @@ [(_ x y ...) (begin (inspect x) (inspect y ...))])) (define (debug:print-error n e . params) ;; normal print (if (debug:debug-mode n) - (with-output-to-port (or e (current-error-port)) + (with-output-to-port (if (port? e) e (current-error-port)) (lambda () (if *logging* (db:log-event (apply conc params)) ;; (apply print "pid:" (current-process-id) " " params) (apply print "ERROR: " params) @@ -201,19 +220,21 @@ (apply print "ERROR: " params) )))) (define (debug:print-info n e . params) (if (debug:debug-mode n) - (with-output-to-port (or e (current-error-port)) + (with-output-to-port (if (port? e) e (current-error-port)) (lambda () (if *logging* (let ((res (format#format #f "INFO: (~a) ~a" n (apply conc params)))) (db:log-event res)) ;; (apply print "pid:" (current-process-id) " " "INFO: (" n ") " params) ;; res) (apply print "INFO: (" n ") " params) ;; res) ))))) + + ;; if a value is printable (i.e. string or number) return the value ;; else return an empty string (define-inline (printable val) (if (or (number? val)(string? val)) val "")) Index: configf.scm ================================================================== --- configf.scm +++ configf.scm @@ -22,18 +22,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))))))))) @@ -41,10 +41,16 @@ (define (config:assoc-safe-add alist key val #!key (metadata #f)) (let ((newalist (filter (lambda (x)(not (equal? key (car x)))) alist))) (append newalist (list (if metadata (list key val metadata) (list key val)))))) + +(define (configf:section-var-set! cfgdat section-name var value #!key (metadata #f)) + (hash-table-set! cfgdat section-name + (config:assoc-safe-add + (hash-table-ref/default cfgdat section-name '()) + var value metadata: metadata))) (define (config:eval-string-in-environment str) (handle-exceptions exn (begin @@ -57,11 +63,11 @@ ;;====================================================================== ;; Make the regexp's needed globally available ;;====================================================================== (define configf:include-rx (regexp "^\\[include\\s+(.*)\\]\\s*$")) -(define configf:script-rx (regexp "^\\[scriptinc\\s+(.*)\\]\\s*$")) ;; include output from a script +(define configf:script-rx (regexp "^\\[scriptinc\\s+(\\S+)([^\\]]*)\\]\\s*$")) ;; include output from a script (define configf:section-rx (regexp "^\\[(.*)\\]\\s*$")) (define configf:blank-l-rx (regexp "^\\s*$")) (define configf:key-sys-pr (regexp "^(\\S+)\\s+\\[system\\s+(\\S+.*)\\]\\s*$")) (define configf:key-val-pr (regexp "^(\\S+)(\\s+(.*)|())$")) (define configf:key-no-val (regexp "^(\\S+)(\\s*)$")) @@ -177,24 +183,55 @@ (and (or (equal? "default" section) (member section sections)) allow-system) ;; account for sections and return allow-system as it might be a symbol such as return-strings allow-system)) +;; given a config hash and a section name, apply that section to all matching sections (using wildcard % or regex if /..../) +;; remove the section when done so that there is no downstream clobbering +;; +(define (configf:apply-wildcards ht section-name) + (if (hash-table-exists? ht section-name) + (let* ((vars (hash-table-ref ht section-name)) + (rxstr (if (string-contains section-name "%") + (string-substitute (regexp "%") ".*" section-name) + (string-substitute (regexp "^/(.*)/$") "\\1" section-name))) + (rx (regexp rxstr))) + ;; (print "\nsection-name: " section-name " rxstr: " rxstr) + (for-each + (lambda (section) + (if section + (let ((same-section (string=? section-name section)) + (rx-match (string-match rx section))) + ;; (print "section: " section " vars: " vars " same-section: " same-section " rx-match: " rx-match) + (if (and (not same-section) rx-match) + (for-each + (lambda (bundle) + ;; (print "bundle: " bundle) + (let ((key (car bundle)) + (val (cadr bundle)) + (meta (if (> (length bundle) 2)(caddr bundle) #f))) + (hash-table-set! ht section (config:assoc-safe-add (hash-table-ref ht section) key val metadata: meta)))) + vars))))) + (hash-table-keys ht)))) + ht) + ;; read a config file, returns hash table of alists ;; read a config file, returns hash table of alists ;; adds to ht if given (must be #f otherwise) ;; envion-patt is a regex spec that identifies sections that will be eval'd ;; in the environment on the fly ;; sections: #f => get all, else list of sections to gather ;; post-section-procs alist of section-pattern => proc, where: (proc section-name next-section-name ht curr-path) +;; apply-wildcards: #t/#f - apply vars from targets with % wildcards to all matching sections ;; -(define (read-config path ht allow-system #!key (environ-patt #f)(curr-section #f)(sections #f)(settings (make-hash-table))(keep-filenames #f)(post-section-procs '())) - (debug:print-info 5 *default-log-port* "read-config " path " allow-system " allow-system " environ-patt " environ-patt " curr-section: " curr-section " sections: " sections " pwd: " (current-directory)) +(define (read-config path ht allow-system #!key (environ-patt #f) (curr-section #f) + (sections #f) (settings (make-hash-table)) (keep-filenames #f) + (post-section-procs '()) (apply-wildcards #t)) (debug:print 9 *default-log-port* "START: " path) (if (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) @@ -201,21 +238,35 @@ (open-input-file path) path)) ;; we can be handed a port (res (if (not ht)(make-hash-table) ht)) (metapath (if (or (debug:debug-mode 9) keep-filenames) - path #f))) + path #f)) + (process-wildcards (lambda (res curr-section-name) + (if (and apply-wildcards + (or (string-contains curr-section-name "%") ;; wildcard + (string-match "/.*/" curr-section-name))) ;; regex + (begin + (configf:apply-wildcards res curr-section-name) + (hash-table-delete! res curr-section-name)))))) ;; NOTE: if the section is a wild card it will be REMOVED from res (let loop ((inl (configf:read-line inp res (calc-allow-system allow-system curr-section sections) settings)) ;; (read-line inp)) (curr-section-name (if curr-section curr-section "default")) (var-flag #f);; turn on for key-var-pr and cont-ln-rx, turn off elsewhere (lead #f)) (debug:print-info 8 *default-log-port* "curr-section-name: " curr-section-name " var-flag: " var-flag "\n inl: \"" inl "\"") (if (eof-object? inl) (begin + ;; process last section for wildcards + (process-wildcards res curr-section-name) (if (string? path) ;; we received a path, not a port, thus we are responsible for closing it. (close-input-port inp)) - (hash-table-delete! res "") ;; we are using "" as a dumping ground and must remove it before returning the ht + (if (list? sections) ;; delete all sections except given when sections is provided + (for-each + (lambda (section) + (if (not (member section sections)) + (hash-table-delete! res section))) ;; we are using "" as a dumping ground and must remove it before returning the ht + (hash-table-keys res))) (debug:print 9 *default-log-port* "END: " path) res) (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)) @@ -229,11 +280,11 @@ (common:nice-path (conc (if curr-conf-dir curr-conf-dir ".") "/" include-file))))) - (if (file-exists? full-conf) + (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) @@ -240,17 +291,17 @@ (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 );; 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 include-script))) + (configf:script-rx ( x include-script params);; handle-exceptions + ;; exn + ;; (begin + ;; (debug:print '(0 2 9) #f "INFO: include from script " include-script " failed.") + ;; (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f)) + (if (and (common:file-exists? include-script)(file-execute-access? include-script)) + (let* ((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)) @@ -265,15 +316,20 @@ (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 "" + ;; (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)) @@ -367,12 +423,34 @@ (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) '() @@ -431,11 +509,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 @@ -535,11 +613,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 () @@ -598,20 +676,42 @@ (lambda (section) (hash-table-set! ht (car section)(cdr section))) adat) ht)) +;; if (define (configf:read-alist fname) - (configf:alist->config - (with-input-from-file fname read))) + (handle-exceptions + exn + #f + (configf:alist->config + (with-input-from-file fname read)))) (define (configf:write-alist cdat fname) - (with-output-to-file fname - (lambda () - (pp (configf:config->alist cdat))))) - - + (if (not (common:faux-lock fname)) + (debug:print 0 *default-log-port* "INFO: Could not get lock on " fname)) + (let* ((dat (configf:config->alist cdat)) + (res + (begin + (with-output-to-file fname ;; first write out the file + (lambda () + (pp dat))) + + (if (common:file-exists? fname) ;; now verify it is readable + (if (configf:read-alist fname) + #t ;; data is good. + (begin + (handle-exceptions + exn + #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) Index: dashboard-tests.scm ================================================================== --- dashboard-tests.scm +++ dashboard-tests.scm @@ -45,11 +45,11 @@ (let ((cfg-ovrd (configf:lookup *configdat* "dashboard" "pre-command"))) (or cfg-ovrd default-override "viewscreen "))) ;; "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'\" &"))) + (or cfg-ovrd default-override " &"))) ;; ";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" @@ -234,11 +234,11 @@ ;; 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)))) + (area-exists (and subarea (common:file-exists? subarea)))) ;; (debug:print-info 0 *default-log-port* "Megatest subarea=" subarea ", area-exists=" area-exists) (if subarea (iup:frame #:title "Megatest Run Info" ; #:expand "YES" (iup:button @@ -337,16 +337,10 @@ (if (not (colors-similar? newcolor (iup:attribute btn "BGCOLOR"))) (iup:attribute-set! btn "BGCOLOR" newcolor)))) btns))) btns)))))) -(define (dashboard-tests:run-html-viewer lfilename) - (let ((htmlviewercmd (configf:lookup *configdat* "setup" "htmlviewercmd"))) - (if htmlviewercmd - (system (conc "(" htmlviewercmd " " lfilename " ) &")) - (iup:send-url lfilename)))) - (define (dashboard-tests:run-a-step info) #t) (define (dashboard-tests:step-run-control testdat stepname testconfig) (iup:dialog ;; #:close_cb (lambda (a)(exit)) ; #:expand "YES" @@ -404,11 +398,11 @@ (test-id (db:test-get-id testdat))) (if (or (not wpatt) (string-match wregx comment)) (begin ;; (rmt:test-set-state-status-by-id run-id test-id #f "WAIVED" comment) - (rmt:test-set-state-status-by run-id test-id #f "WAIVED" comment) + (rmt:test-set-state-status run-id test-id #f "WAIVED" comment) (db:test-set-status! testdat "WAIVED") (cmtcmd comment) (iup:destroy! dlog)))))) (iup:button "Cancel" #:expand "HORIZONTAL" @@ -463,35 +457,35 @@ keydat) "/")) (item-path (db:test-get-item-path testdat)) ;; this next block was added to fix a bug where variables were ;; needed. Revisit this. - (runconfig (let ((runconfigf (conc *toppath* "/runconfigs.config"))) - (if (file-exists? runconfigf) + (runconfig (let ((runconfigf (conc *toppath* "/runconfigs.config"))) ;; no rush but it would be good to convert this call to use runconfig:read + (if (common:file-exists? runconfigf) (handle-exceptions exn #f ;; do nothing, just keep on trucking .... (setup-env-defaults runconfigf run-id (make-hash-table) keydat environ-patt: keystring)) (make-hash-table)))) (testconfig (begin ;; (runs:set-megatest-env-vars run-id inrunname: runname testname: test-name itempath: item-path) (runs:set-megatest-env-vars run-id inkeyvals: keydat inrunname: runname intarget: keystring testname: testname itempath: item-path) ;; these may be needed by the launching process (handle-exceptions - exn - (tests:get-testconfig (db:test-get-testname testdat) (db:test-get-item-path testdat) test-registry #f) - (tests:get-testconfig (db:test-get-testname testdat) test-registry #t)))) + exn ;; NOTE: I've no idea why this was written this way. Research, study and fix needed! + (tests:get-testconfig (db:test-get-testname testdat) (db:test-get-item-path testdat) test-registry #f allow-write-cache: #f) + (tests:get-testconfig (db:test-get-testname testdat) item-path test-registry #t allow-write-cache: #f)))) (viewlog (lambda (x) - (if (file-exists? logfile) + (if (common:file-exists? logfile) ;(system (conc "firefox " logfile "&")) - (dashboard-tests:run-html-viewer logfile) + (dcommon:run-html-viewer logfile) (message-window (conc "File " logfile " not found"))))) (view-a-log (lambda (lfile) (let ((lfilename (conc rundir "/" lfile))) ;; (print "lfilename: " lfilename) - (if (file-exists? lfilename) + (if (common:file-exists? lfilename) ;(system (conc "firefox " logfile "&")) - (dashboard-tests:run-html-viewer lfilename) + (dcommon:run-html-viewer lfilename) (message-window (conc "File " lfilename " not found")))))) (xterm (lambda (x) (if (directory-exists? rundir) (let ((shell (if (get-environment-variable "SHELL") (conc "-e " (get-environment-variable "SHELL")) @@ -502,11 +496,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) Index: dashboard.scm ================================================================== --- dashboard.scm +++ dashboard.scm @@ -47,11 +47,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 +85,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)) @@ -99,29 +100,40 @@ (if (args:get-arg "-h") (begin (print help) (exit))) -(if (not (common:on-homehost?)) - (begin - (debug:print 0 *default-log-port* "ERROR: Current policy requires running dashboard on homehost: " (common:get-homehost)))) - ;; TODO: Move this inside (main) ;; (if (not (launch:setup)) (begin (print "Failed to find megatest.config, exiting") (exit 1))) +;; deal with RH 5.11 gtk lib or iup lib missing detachbox feature +;; first check for the switch +;; +(if (or (args:get-arg "-rh5.11") + (configf:lookup *configdat* "dashboard" "no-detachbox")) + (set! iup:detachbox iup:vbox)) + +(if (not (common:on-homehost?)) + (begin + (debug:print 0 *default-log-port* "WARNING: Current policy requires running dashboard on homehost: " (common:get-homehost)))) + +;; RA => Might require revert for filters ;; create a watch dog to move changes from lt/.db/*.db to megatest.db ;; -(if (file-write-access? (conc *toppath* "/megatest.db")) - (thread-start! (make-thread common:watchdog "Watchdog thread")) - (if (not (args:get-arg "-use-db-cache")) - (begin - (debug:print-info 0 *default-log-port* "Forcing db-cache mode due to read-only access to megatest.db") - (hash-table-set! args:arg-hash "-use-db-cache" #t)))) +;;;(if (file-write-access? (conc *toppath* "/megatest.db")) +;;(debug:print-info 13 *default-log-port* "Before common:watchdog spawn") +(thread-start! (make-thread common:watchdog "Watchdog thread")) +;;(debug:print-info 13 *default-log-port* "After common:watchdog spawn") +;; (if (not (args:get-arg "-use-db-cache")) +;; (begin +;; (debug:print-info 0 *default-log-port* "Forcing db-cache mode due to read-only access to megatest.db") +;; (hash-table-set! args:arg-hash "-use-db-cache" #t)));;;) +;;) ;; data common to all tabs goes here ;; (defstruct dboard:commondat ((curr-tab-num 0) : number) @@ -146,14 +158,19 @@ )) ;; RA => returns the tabdat stored at hashkey passed in commondat-tabdats table (e.g. 0 gives summary) ;; (define (dboard:common-get-tabdat commondat #!key (tab-num #f)) - (hash-table-ref/default - (dboard:commondat-tabdats commondat) - (or tab-num (dboard:commondat-curr-tab-num commondat)) ;; tab-num value is curr-tab-num value in passed commondat - #f)) + (let* ((tnum (or tab-num + (dboard:commondat-curr-tab-num commondat) + 0)) ;; tab-num value is curr-tab-num value in passed commondat + (ht (dboard:commondat-tabdats commondat)) + (res (hash-table-ref/default ht tnum #f))) + (or res + (let ((new-tabdat (dboard:tabdat-make-data))) + (hash-table-set! ht tnum new-tabdat) + new-tabdat)))) ;; RA => sets the tabdat passed to the hashkey at commondat:tabdats hash table ;; (define (dboard:common-set-tabdat! commondat tabnum tabdat) (hash-table-set! @@ -195,11 +212,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 @@ -211,13 +230,13 @@ ((item-test-names '()) : list) ;; list of itemized tests ((run-keys (make-hash-table)) : hash-table) (runs-matrix #f) ;; used in newdashboard ((start-run-offset 0) : number) ;; left-right slider value ((start-test-offset 0) : number) ;; up-down slider value - ((runs-btn-height (or (configf:lookup *configdat* "dashboard" "btn-height") "x14")) : string) ;; was 12 + ((runs-btn-height (or (configf:lookup *configdat* "dashboard" "btn-height") "x16")) : string) ;; was 12 ((runs-btn-fontsz (or (configf:lookup *configdat* "dashboard" "btn-fontsz") "10")) : string) ;; was 8 - ((runs-cell-width (or (configf:lookup *configdat* "dashboard" "cell-width") "60")) : string) ;; was 50 + ((runs-cell-width (or (configf:lookup *configdat* "dashboard" "cell-width") "50")) : string) ;; was 50 ((all-test-names '()) : list) ;; Canvas and drawing data (cnv #f) (cnv-obj #f) @@ -250,11 +269,11 @@ ;; Selector variables curr-run-id ;; current row to display in Run summary view prev-run-id ;; previous runid selected before current runid was selected (used in xor-two-runs runs summary mode curr-test-ids ;; used only in dcommon:run-update which is used in newdashboard - ((filters-changed #t) : boolean) ;; to to indicate that the user changed filters for this tab + ((filters-changed #t) : boolean) ;; to indicate that the user changed filters for this tab ((last-filter-str "") : string) ;; conc the target runname and testpatt for a signature of changed filters ((hide-empty-runs #f) : boolean) ((hide-not-hide #t) : boolean) ;; toggle for hide/not hide empty runs (hide-not-hide-button #f) ((searchpatts (make-hash-table)) : hash-table) ;; @@ -330,11 +349,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 @@ -525,12 +544,12 @@ (access-mode (dboard:tabdat-access-mode tabdat)) (num-to-get (string->number (or (configf:lookup *configdat* "setup" "num-tests-to-get") "200"))) (states (hash-table-keys (dboard:tabdat-state-ignore-hash tabdat))) (statuses (hash-table-keys (dboard:tabdat-status-ignore-hash tabdat))) - (do-not-use-db-file-timestamps #f) ;; (configf:lookup *configdat* "setup" "do-not-use-db-file-timestamps")) ;; this still hosts runs-summary-tab - (do-not-use-query-timestamps #f) ;; (configf:lookup *configdat* "setup" "do-not-use-query-timestamps")) ;; this no longer troubles runs-summary-tab + (do-not-use-db-file-timestamps #t) ;; (configf:lookup *configdat* "setup" "do-not-use-db-file-timestamps")) ;; this still hosts runs-summary-tab + (do-not-use-query-timestamps #t) ;; (configf:lookup *configdat* "setup" "do-not-use-query-timestamps")) ;; this no longer troubles runs-summary-tab (sort-info (get-curr-sort)) (sort-by (vector-ref sort-info 1)) (sort-order (vector-ref sort-info 2)) (bubble-type (if (member sort-order '(testname)) 'testname @@ -539,14 +558,15 @@ (run-dat (or (hash-table-ref/default (dboard:tabdat-allruns-by-id tabdat) run-id #f) (let ((rd (dboard:rundat-make-init run: run key-vals: key-vals))) (hash-table-set! (dboard:tabdat-allruns-by-id tabdat) run-id rd) rd))) ;; (prev-tests (dboard:rundat-tests prev-dat)) ;; (vector-ref prev-dat 1)) - (last-update (if (or do-not-use-query-timestamps - (dboard:tabdat-filters-changed tabdat)) - 0 - (dboard:rundat-last-update run-dat))) + (last-update (if ;;(or + do-not-use-query-timestamps + ;;(dboard:tabdat-filters-changed tabdat)) + 0 + (dboard:rundat-last-update run-dat))) (last-db-time (if do-not-use-db-file-timestamps 0 (dboard:rundat-last-db-time run-dat))) (db-path (or (dboard:rundat-db-path run-dat) (let* ((db-dir (common:get-db-tmp-area)) @@ -557,12 +577,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 @@ -632,17 +651,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))) @@ -715,15 +732,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))) @@ -782,11 +797,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))))))) @@ -1075,10 +1098,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) @@ -1366,11 +1390,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))) @@ -1387,14 +1411,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)) @@ -1404,11 +1434,11 @@ (tb (iup:treebox #:value 0 #:name "Runs" #:expand "YES" - #:addexpanded "NO" + #:addexpanded "YES" #:size "10x" #:selection-cb (lambda (obj id state) (debug:catch-and-dump (lambda () @@ -1430,11 +1460,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 ;;====================================================================== ;; @@ -1499,11 +1532,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 @@ -1544,15 +1577,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)) @@ -1601,35 +1634,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)) @@ -1645,12 +1678,11 @@ (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)) (dboard:tabdat-keys tabdat))) @@ -1698,12 +1730,12 @@ (tests-mindat (dcommon:minimize-test-data tests-dat))) ;; reduces data for display (dboard:tabdat-last-runs-update-set! tabdat (- (current-seconds) 2)) (hash-table-set! (dboard:tabdat-last-test-dat tabdat) run-id tests-dat) (hash-table-set! (dboard:tabdat-run-update-times tabdat) run-id (- (current-seconds) 10)) (when (not run) - (BB> "ERROR: NO RUN FOR RUN-ID run-id="run-id) - (BB> "runs-hash-> " (hash-table->alist runs-hash)) + (debug:print-info 13 *default-log-port* "ERROR: NO RUN FOR RUN-ID run-id="run-id) + (debug:print-info 13 *default-log-port* "runs-hash-> " (hash-table->alist runs-hash)) ) tests-mindat)) (define (dashboard:runs-summary-xor-matrix-content tabdat runs-hash #!key (hide-clean #f)) (let* ((src-run-id (dboard:tabdat-prev-run-id tabdat)) @@ -1717,12 +1749,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) @@ -1734,13 +1765,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))) @@ -1821,11 +1850,10 @@ (hash-table-set! cell-lookup key test-id) (if (not (equal? (iup:attribute run-matrix key) (cadr value))) (begin (set! changed #t) (iup:attribute-set! run-matrix key (cadr value)) - ;; (print "RA=> value" (car value)) (iup:attribute-set! run-matrix (conc "BGCOLOR" key) (car value)))))) matrix-content) ;; Col labels - do after setting Cell contents so they are accounted for in the size calc. @@ -1856,11 +1884,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") @@ -1893,11 +1921,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) @@ -1930,20 +1958,20 @@ exn (begin (print-call-chain) (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) (debug:print 0 *default-log-port* "ERROR: failed call procedure \"" updater - "\", with; tabnum=" tabnum ", view-name=" view-name + "\", with; tabnum=" tab-num ", view-name=" view-name ", and views-cfgdat and megatest configdat as parameters. To debug try loading in the repl: megatest -repl") (set! success #f)) (debug:print 4 *default-log-port* "Running updater for tab " view-name " with proc " updater " and tab-num: " tab-num) ((eval (string->symbol updater)) commondat tabs tab-num view-name views-cfgdat *configdat*))) tab-num: tab-num)) - (if success - (begin - ;; (iup:attribute-set! tabs (conc "TABTITLE" tab-num) view-name) - (dboard:common-set-tabdat! commondat tab-num (dboard:tabdat-make-data)))) + ;;(if success + ;; (begin + ;; ;; (iup:attribute-set! tabs (conc "TABTITLE" tab-num) view-name) + ;; (dboard:common-set-tabdat! commondat tab-num (dboard:tabdat-make-data)))) result-child)) (define (dboard:runs-summary-buttons-updater tabdat) @@ -2039,11 +2067,11 @@ (let* ((update-mutex (dboard:commondat-update-mutex commondat)) (tb (iup:treebox #:value 0 #:name "Runs" #:expand "YES" - #:addexpanded "NO" + #:addexpanded "YES" #:selection-cb (lambda (obj id state) (debug:catch-and-dump (lambda () ;; (print "obj: " obj ", id: " id ", state: " state) @@ -2075,21 +2103,22 @@ ;; Bummer - we dont have the global get/set api mapped in chicken ;; (let* ((modkeys (iup:global "MODKEYSTATE"))) ;; (BB> "modkeys="modkeys)) - (BB> "click-cb: obj="obj" lin="lin" col="col" status="status) + (debug:print-info 13 *default-log-port* "click-cb: obj="obj" lin="lin" col="col" status="status) ;; status is corrupted on Brandon's home machine. will have to wait until after shutdown to see if it is still broken in PDX SLES (let* ((toolpath (car (argv))) (key (conc lin ":" col)) (test-id (hash-table-ref/default cell-lookup key -1)) (run-id (dboard:tabdat-curr-run-id tabdat)) (run-info (rmt:get-run-info run-id)) (target (rmt:get-target run-id)) (runname (db:get-value-by-header (db:get-rows run-info) (db:get-header run-info) "runname")) - (test-name (db:test-get-testname (rmt:get-test-info-by-id run-id test-id))) + (test-info (rmt:get-test-info-by-id run-id test-id)) + (test-name (db:test-get-testname test-info)) (testpatt (let ((tlast (rmt:tasks-get-last target runname))) (if tlast (let ((tpatt (tasks:task-get-testpatt tlast))) (if (member tpatt '("0" 0)) ;; known bad historical value - remove in 2017 "%" @@ -2099,26 +2128,26 @@ (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 " &"))) - (BB> "status-chars=["status-chars"] status=["status"]") + (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)) ((member #\2 status-chars) ;; 2 is middle mouse button - (BB> "mmb- test-name="test-name" testpatt="testpatt) - (iup:show (dashboard:popup-menu run-id test-id target runname test-name testpatt item-test-path) ;; popup-menu + (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 #:x 'mouse #:y 'mouse #:modal? "NO") ) (else - (BB> "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) ;; popup-menu + (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 #:x 'mouse #:y 'mouse #:modal? "NO") ) ) @@ -2149,10 +2178,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 @@ -2171,10 +2218,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 () @@ -2213,17 +2270,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")) @@ -2253,56 +2310,82 @@ ))) - (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) + (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 (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) @@ -2311,13 +2394,37 @@ (conc toolpath " -test " run-id "," test-id " &"))) (system testpanel-cmd) ))) (iup:menu-item - (conc "View Log (not yet implemented) " item-test-path) + (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 @@ -2339,11 +2446,11 @@ ;; (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")))) + " -state RUNNING,REMOTEHOSTSTART,LAUNCHED,NOT_STARTED")))) (iup:menu-item "Run" (iup:menu @@ -2381,11 +2488,20 @@ (lambda (obj) (common:run-a-command (conc "megatest -set-state-status KILLREQ,n/a -target " target " -runname " runname " -testpatt % " - " -state RUNNING,REMOTEHOSTSTART,LAUNCHED")))))) + " -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")))))) (iup:menu-item "Test" (iup:menu (iup:menu-item (conc "Rerun " item-test-path) @@ -2404,10 +2520,19 @@ (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 @@ -2472,10 +2597,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))))) @@ -2524,11 +2652,11 @@ ((>= keynum nkeys) (vector-set! header runnum keyvec) (set! hdrlst (cons (apply iup:vbox (reverse res)) hdrlst)) (loop (+ runnum 1) 0 (make-vector nkeys) '())) (else - (let ((labl (iup:label "" #:size (conc cell-width btn-height) #:fontsize btn-fontsz #:expand "NO"))) ;; #:expand "HORIZONTAL" "60x15" + (let ((labl (iup:label "" #:size (conc cell-width btn-height) #:fontsize btn-fontsz #:expand "HORIZONTAL"))) ;; #:expand "HORIZONTAL" "60x15" (vector-set! keyvec keynum labl) (loop runnum (+ keynum 1) keyvec (cons labl res)))))) ;; By here the hdrlst contains a list of vboxes containing nkeys labels (let loop ((runnum 0) (testnum 0) @@ -2543,11 +2671,11 @@ (else (let* ((button-key (mkstr runnum testnum)) (butn (iup:button "" ;; button-key #:size (conc cell-width btn-height ) - #:expand "NO" + #:expand "HORIZONTAL" #:fontsize btn-fontsz #:button-cb (lambda (obj a pressed x y btn . rem) ;; (print "pressed= " pressed " x= " x " y= " y " rem=" rem " btn=" btn " string? " (string? btn)) (if (substring-index "3" btn) @@ -2558,11 +2686,12 @@ (run-id (db:test-get-run_id (vector-ref buttndat 3))) (run-info (rmt:get-run-info run-id)) (target (rmt:get-target run-id)) (runname (db:get-value-by-header (db:get-rows run-info) (db:get-header run-info) "runname")) - (test-name (db:test-get-testname (rmt:get-test-info-by-id run-id test-id))) + (test-info (rmt:get-test-info-by-id run-id test-id)) + (test-name (db:test-get-testname test-info)) (testpatt (let ((tlast (rmt:tasks-get-last target runname))) (if tlast (let ((tpatt (tasks:task-get-testpatt tlast))) (if (member tpatt '("0" 0)) ;; known bad historical value - remove in 2017 "%" @@ -2570,11 +2699,11 @@ "%"))) (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) ;; popup-menu + (iup:show (dashboard:popup-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") )) @@ -2595,20 +2724,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 @@ -2653,10 +2785,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") @@ -2693,11 +2826,11 @@ (get-environment-variable "DASHBOARDROWS") "15")))) (define *tim* (iup:timer)) (define *ord* #f) -(iup:attribute-set! *tim* "TIME" 300 ) +(iup:attribute-set! *tim* "TIME" (or (configf:lookup *configdat* "dashboard" "poll-interval") "1000")) (iup:attribute-set! *tim* "RUN" "YES") (define *last-recalc-ended-time* 0) (define (dashboard:recalc modtime please-update-buttons last-db-update-time) @@ -2708,26 +2841,26 @@ ;; (define *monitor-db-path* #f) (define *last-monitor-update-time* 0) ;; Force creation of the db in case it isn't already there. -(tasks:open-db) +;; (tasks:open-db) (define (dashboard:get-youngest-run-db-mod-time dbdir) (handle-exceptions exn (begin - (debug:print 0 *default-log-port* "WARNING: error in accessing databases in get-youngest-run-db-mod-time: " ((condition-property-accessor 'exn 'message) exn) " db-dir="dbdir) + (debug:print 2 *default-log-port* "WARNING: error in accessing databases in get-youngest-run-db-mod-time: " ((condition-property-accessor 'exn 'message) exn) " db-dir="dbdir) (current-seconds)) ;; something went wrong - just print an error and return current-seconds (common:max (map (lambda (filen) (file-modification-time filen)) (glob (conc dbdir "/*.db*")))))) (define (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 @@ -2852,13 +2985,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)) @@ -3080,11 +3211,11 @@ (let* ((val (vector-ref hed 2)) (newmin (if (< val min) val min)) (newmax (if (> val max) val max)) (newres (cons val res))) (if (null? tal) - (values (reverse res) newmin newmax) + (values (reverse res) (- newmin 2) (+ newmax 2)) (loop (car tal)(cdr tal) newres newmin newmax))))))) (if (not (hash-table-exists? graph-matrix-table fieldn)) (begin (let* ((graph-color-rgb (vg:generate-color-rgb)) (graph-color (vg:iup-color->number graph-color-rgb)) @@ -3425,11 +3556,11 @@ ;;(print "RA => calling runs-tab-updater with commondat " commondat " tab-num " tab-num) ;;(tabdat-values tabdat) ;;RA added ;; (pp (dboard:tabdat->alist tabdat)) ;; (if (dashboard:database-changed? commondat tabdat context-key: 'runs-rundat) (dashboard:do-update-rundat tabdat) - ;;(BB> "dashboard:runs-tab-updater") + ;;(debug:print-info 13 *default-log-port* "dashboard:runs-tab-updater") ;;(inspect tabdat) (let ((uidat (dboard:commondat-uidat commondat))) ;;(print "RA => Calling update-buttons with tabdat : " tabdat " uidat " uidat) (update-buttons tabdat uidat (dboard:tabdat-numruns tabdat) (dboard:tabdat-num-tests tabdat))) @@ -3440,11 +3571,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... @@ -3499,12 +3630,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.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 @@ -14,15 +14,13 @@ ;;====================================================================== ;; dbstruct vector containing all the relevant dbs like main.db, megatest.db, run.db etc (use (srfi 18) extras tcp stack) -(use sqlite3 srfi-1 posix regex regex-case srfi-69 csv-xml s11n md5 message-digest base64 format dot-locking z3 typed-records sql-null matchable) +(use sqlite3 srfi-1 posix regex regex-case srfi-69 csv-xml s11n md5 message-digest base64 format dot-locking z3 typed-records matchable) (import (prefix sqlite3 sqlite3:)) (import (prefix base64 base64:)) -(include "/nfs/site/disks/icf_fdk_cw_gwa002/srehman/fossil/dbi/dbi.scm") -(import (prefix dbi dbi:)) (declare (unit db)) (declare (uses common)) (declare (uses keys)) (declare (uses ods)) @@ -44,17 +42,17 @@ ;; each db entry is a pair ( db . dbfilepath ) ;; I propose this record evolves into the area record ;; (defstruct dbr:dbstruct - ;; (tmpdb #f) + (tmpdb #f) (dbstack #f) ;; stack for tmp db handles, do not initialize with a stack (mtdb #f) (refndb #f) - (slave-dbs '()) (homehost #f) ;; not used yet (on-homehost #f) ;; not used yet + (read-only #f) ) ;; goal is to converge on one struct for an area but for now it is too confusing ;; record for keeping state,status and count for doing roll-ups in ;; iterated tests @@ -190,58 +188,87 @@ ;; 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: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. (if file-write ;; dir-writable - (let (;; (lock (obtain-dot-lock fname 1 5 10)) - (db (sqlite3:open-database fname))) - (sqlite3:set-busy-handler! db (make-busy-timeout 136000)) - ;; (db:set-sync db) - (sqlite3:execute db "PRAGMA synchronous = 0;") - (if (not file-exists) - (begin - (if (string-match "^/tmp/.*" fname) ;; this is a file in /tmp - (sqlite3:execute db "PRAGMA journal_mode=WAL;") - (print "Creating " fname " in NON-WAL mode.")) - (initproc db))) - ;; (release-dot-lock fname) - db) - (begin - (debug:print 2 *default-log-port* "WARNING: opening db in non-writable dir " fname) - (sqlite3:open-database fname))))) ;; ) + (condition-case + (let* ((lockfname (conc fname ".lock")) + (readyfname (conc parent-dir "/.ready-" raw-fname)) + (readyexists (common:file-exists? readyfname))) + (if (not readyexists) + (common:simple-file-lock-and-wait lockfname)) + (let ((db (sqlite3:open-database fname))) + (sqlite3:set-busy-handler! db (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;") + (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 + readyfname + (lambda () + (print "Ready at " + (seconds->year-work-week/day-time + (current-seconds))))))) + db)) + (exn (io-error) (debug:print 0 *default-log-port* "ERROR: i/o error with " fname ". Check permissions, disk space etc. and try again.")) + (exn (corrupt) (debug:print 0 *default-log-port* "ERROR: database " fname " is corrupt. Repair it to proceed.")) + (exn (busy) (debug:print 0 *default-log-port* "ERROR: database " fname " is locked. Try copying to another location, remove original and copy back.")) + (exn (permission)(debug:print 0 *default-log-port* "ERROR: database " fname " has some permissions problem.")) + (exn () (debug:print 0 *default-log-port* "ERROR: Unknown error with database " fname " message: " ((condition-property-accessor 'exn 'message) exn)))) + + (condition-case + (begin + (debug:print 2 *default-log-port* "WARNING: opening db in non-writable dir " fname) + (let ((db (sqlite3:open-database fname))) + ;;(mutex-unlock! *db-open-mutex*) + db)) + (exn (io-error) (debug:print 0 *default-log-port* "ERROR: i/o error with " fname ". Check permissions, disk space etc. and try again.")) + (exn (corrupt) (debug:print 0 *default-log-port* "ERROR: database " fname " is corrupt. Repair it to proceed.")) + (exn (busy) (debug:print 0 *default-log-port* "ERROR: database " fname " is locked. Try copying to another location, remove original and copy back.")) + (exn (permission)(debug:print 0 *default-log-port* "ERROR: database " fname " has some permissions problem.")) + (exn () (debug:print 0 *default-log-port* "ERROR: Unknown error with database " fname " message: " ((condition-property-accessor 'exn 'message) exn)))) + ))) + + + + + ;; ;; This routine creates the db. 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) @@ -272,97 +299,92 @@ ;; (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)) +(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)) ;; 0)) - (dbexists (file-exists? dbpath)) - (dbfexists (file-exists? (conc dbpath "/megatest.db"))) - (tmpdb (db:open-megatest-db path: dbpath)) ;; lock-create-open dbpath db:initialize-main-db)) + (let* ((dbpath (db:dbfile-path )) ;; path to tmp db area + (dbexists (common:file-exists? dbpath)) + (tmpdbfname (conc dbpath "/megatest.db")) + (dbfexists (common:file-exists? tmpdbfname)) ;; (conc dbpath "/megatest.db"))) + (mtdbexists (common:file-exists? (conc *toppath* "/megatest.db"))) + (mtdb (db:open-megatest-db)) + (mtdbpath (db:dbdat-get-path mtdb)) + (tmpdb (db:open-megatest-db path: dbpath)) ;; lock-create-open dbpath db:initialize-main-db)) (refndb (db:open-megatest-db path: dbpath name: "megatest_ref.db")) - (write-access (file-write-access? dbpath))) - - (if (args:get-arg "-server") - (if (configf:get-section *configdat* "ext-sync") - (let* ((dblist (configf:get-section *configdat* "ext-sync")) - (res '()) - (cfgdb #f)) - (for-each (lambda (dbitem) - (let* ((stringsplit (string-split (cadr dbitem))) - (dbtype (string->symbol (car stringsplit))) - (dbpath (cadr stringsplit))) - (case dbtype - ((sqlite3) - (set! cfgdb (dbi:open dbtype (cons (cons 'dbname dbpath) '()) )) - (db:initialize-main-db (dbi:db-conn cfgdb)) - (db:initialize-run-id-db (dbi:db-conn cfgdb)) - (set! res (cons (cons cfgdb dbpath) res))) - ((pg) - (let* ((dbinfo '())) - (for-each - (lambda (x) - (if (not (eqv? (string->symbol x) dbtype)) - (let* ((pair (string-split x ":"))) - (if (not (eqv? pair '())) - (set! dbinfo (cons (cons (string->symbol (car pair)) (cadr pair)) dbinfo)))))) - stringsplit) - (set! cfgdb (dbi:open dbtype dbinfo)) - (set! res (cons (cons cfgdb (alist-ref 'host dbinfo)) res)) - ))))) - dblist) - (dbr:dbstruct-slave-dbs-set! dbstruct res) - ))) - + (write-access (file-write-access? mtdbpath)) + (mtdbmodtime (if mtdbexists (common:lazy-sqlite-db-modification-time mtdbpath) #f)) + (tmpdbmodtime (if dbfexists (common:lazy-sqlite-db-modification-time tmpdbfname) #f)) + (modtimedelta (and mtdbmodtime tmpdbmodtime (- mtdbmodtime tmpdbmodtime)))) + + ;;(debug:print-info 13 *default-log-port* "db:open-db>> mtdbpath="mtdbpath" mtdbexists="mtdbexists" and write-access="write-access) (if (and dbexists (not write-access)) - (set! *db-write-access* #f)) + (begin + (set! *db-write-access* #f) + (dbr:dbstruct-read-only-set! dbstruct #t))) (dbr:dbstruct-mtdb-set! dbstruct mtdb) - (dbr:dbstruct-dbstack-set! dbstruct (make-stack)) + (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 (and (not dbfexists) - write-access) ;; *db-write-access*) ;; did not have a prior db and do have write access + (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 0 *default-log-port* "filling db " (db:dbdat-get-path tmpdb) " with data from " (db:dbdat-get-path mtdb)) - (db:sync-tables (db:sync-all-tables-list dbstruct) #f mtdb refndb tmpdb)) - (debug:print 0 *default-log-port* " db, " (db:dbdat-get-path tmpdb) " already exists, not propogating data from " (db:dbdat-get-path mtdb))) + (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) + (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 tmpdb)))) ;; 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)) - (or *dbstruct-db* - (if (common:on-homehost?) - (let* ((dbstruct (make-dbr:dbstruct))) - (db:open-db dbstruct areapath: areapath) - (set! *dbstruct-db* dbstruct) - dbstruct) - (begin - (debug:print 0 *default-log-port* "ERROR: attempt to open database when not on homehost. Exiting. Homehost: " (common:get-homehost)) - (exit 1))))) +(define (db:setup do-sync #!key (areapath #f)) + ;; + (cond + (*dbstruct-db* *dbstruct-db*);; TODO: when multiple areas are supported, this optimization will be a hazard + (else ;;(common:on-homehost?) + (debug:print-info 13 *default-log-port* "db:setup entered (first time, not cached.)") + (let* ((dbstruct (make-dbr:dbstruct))) + (when (not *toppath*) + (debug:print-info 13 *default-log-port* "in db:setup, *toppath* not set; calling launch:setup") + (launch:setup areapath: areapath)) + (debug:print-info 13 *default-log-port* "Begin db:open-db") + (db:open-db dbstruct areapath: areapath do-sync: do-sync) + (debug:print-info 13 *default-log-port* "Done db:open-db") + (set! *dbstruct-db* dbstruct) + ;;(debug:print-info 13 *default-log-port* "new dbstruct = "(dbr:dbstruct->alist dbstruct)) + dbstruct)))) + ;; (else + ;; (debug:print 0 *default-log-port* "ERROR: attempt to open database when not on homehost. Exiting. Homehost: " (common:get-homehost)) + ;; (exit 1)))) ;; Open the classic megatest.db file (defaults to open in toppath) ;; ;; NOTE: returns a dbdat not a dbstruct! ;; (define (db:open-megatest-db #!key (path #f)(name #f)) - (let* ((dbpath (conc (or path *toppath*) "/" (or name "megatest.db"))) - (dbexists (file-exists? dbpath)) + (let* ((dbdir (or path *toppath*)) + (dbpath (conc dbdir "/" (or name "megatest.db"))) + (dbexists (common:file-exists? dbpath)) (db (db:lock-create-open dbpath (lambda (db) - (db:initialize-main-db db) - (db:initialize-run-id-db db)))) + (db:initialize-main-db db) + ;;(db:initialize-run-id-db db) + ))) (write-access (file-write-access? dbpath))) + (debug:print-info 13 *default-log-port* "db:open-megatest-db "dbpath) (if (and dbexists (not write-access)) (set! *db-write-access* #f)) (cons db dbpath))) ;; sync run to disk if touched @@ -380,24 +402,47 @@ (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) - (begin - ;; (db:sync-touched dbstruct 0 force-sync: #t) ;; NO. Do not do this here. Instead we rely on a server to be started when there are writes, even if the server itself is not going to be used as a server. + (handle-exceptions + exn + (begin + (debug:print 0 *default-log-port* "WARNING: Finalizing failed, " ((condition-property-accessor 'exn 'message) exn)) + (print-call-chain *default-log-port*)) + ;; (db:sync-touched dbstruct 0 force-sync: #t) ;; NO. Do not do this here. Instead we rely on a server to be started when there are writes, even if the server itself is not going to be used as a server. (let ((tdbs (map db:dbdat-get-db (stack->list (dbr:dbstruct-dbstack dbstruct)))) (mdb (db:dbdat-get-db (dbr:dbstruct-mtdb dbstruct))) (rdb (db:dbdat-get-db (dbr:dbstruct-refndb dbstruct)))) - (map sqlite3:finalize! tdbs) - (if mdb (sqlite3:finalize! mdb)) - (if rdb (sqlite3:finalize! rdb)))))) - + (map (lambda (db) + (db:safely-close-sqlite3-db db)) +;; (if (sqlite3:database? db) +;; (sqlite3:finalize! db))) + tdbs) + (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)) ;; (hash-table-keys locdbs))))) @@ -414,92 +459,82 @@ (list ;; (list "strs" ;; '("id" #f) ;; '("str" #f)) (list "tests" - '("id" "INTEGER" 'key) - '("run_id" "INTEGER") - '("testname" "TEXT") - '("host" "TEXT") - '("cpuload" "REAL") - '("diskfree" "INTEGER") - '("uname" "TEXT") - '("rundir" "TEXT") - '("shortdir" "TEXT") - '("item_path" "TEXT") - '("state" "TEXT") - '("status" "TEXT") - '("attemptnum" "INTEGER") - '("final_logf" "TEXT") - '("logdat" "TEXT") - '("run_duration" "INTEGER") - '("comment" "TEXT") - '("event_time" "INTEGER") - '("fail_count" "INTEGER") - '("pass_count" "INTEGER") - '("archived" "INTEGER")) + '("id" #f) + '("run_id" #f) + '("testname" #f) + '("host" #f) + '("cpuload" #f) + '("diskfree" #f) + '("uname" #f) + '("rundir" #f) + '("shortdir" #f) + '("item_path" #f) + '("state" #f) + '("status" #f) + '("attemptnum" #f) + '("final_logf" #f) + '("logdat" #f) + '("run_duration" #f) + '("comment" #f) + '("event_time" #f) + '("fail_count" #f) + '("pass_count" #f) + '("archived" #f) + '("last_update" #f)) (list "test_steps" - '("id" "INTEGER" 'key) - '("test_id" "INTEGER") - '("stepname" "TEXT") - '("state" "TEXT") - '("status" "TEXT") - '("event_time" "INTEGER") - '("comment" "TEXT") - '("logfile" "TEXT")) + '("id" #f) + '("test_id" #f) + '("stepname" #f) + '("state" #f) + '("status" #f) + '("event_time" #f) + '("comment" #f) + '("logfile" #f) + '("last_update" #f)) (list "test_data" - '("id" "INTEGER" 'key) - '("test_id" "INTEGER") - '("category" "TEXT") - '("variable" "TEXT") - '("value" "REAL") - '("expected" "REAL") - '("tol" "REAL") - '("units" "TEXT") - '("comment" "TEXT") - '("status" "TEXT") - '("type" "TEXT")))) + '("id" #f) + '("test_id" #f) + '("category" #f) + '("variable" #f) + '("value" #f) + '("expected" #f) + '("tol" #f) + '("units" #f) + '("comment" #f) + '("status" #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))) (list (list "keys" - '("id" "INTEGER" 'key) - '("fieldname" "TEXT") - '("fieldtype" "TEXT")) - (list "metadat" - '("id" "INTEGER" 'key) - '("var" "TEXT") - '("val" "TEXT")) - (list "runs" - '("id" "INTEGER" 'key) - '("release" "TEXT") - '("iteration" "TEXT") - '("testsuite_mode" "TEXT") - '("runname" "TEXT") - '("state" "TEXT") - '("status" "TEXT") - '("owner" "TEXT") - '("event_time" "INTEGER") - '("comment" "TEXT") - '("fail_count" "INTEGER") - '("pass_count" "INTEGER")) - + '("id" #f) + '("fieldname" #f) + '("fieldtype" #f)) + (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" "last_update")))) (list "test_meta" - '("id" "INTEGER" 'key) - '("testname" "TEXT") - '("author" "TEXT") - '("owner" "TEXT") - '("description" "TEXT") - '("reviewed" "TEXT") - '("iterated" "TEXT") - '("avg_runtime" "REAL") - '("avg_disk" "REAL") - '("tags" "TEXT") - '("jobgroup" "TEXT"))))) + '("id" #f) + '("testname" #f) + '("owner" #f) + '("description" #f) + '("reviewed" #f) + '("iterated" #f) + '("avg_runtime" #f) + '("avg_disk" #f) + '("tags" #f) + '("jobgroup" #f))))) (define (db:sync-all-tables-list dbstruct) (append (db:sync-main-list dbstruct) db:sync-tests-only)) @@ -513,11 +548,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 @@ -530,12 +565,10 @@ (let* ((dbpath (db:dbdat-get-path dbdat)) (dbdir (pathname-directory dbpath)) (fname (pathname-strip-directory dbpath))) (debug:print-info 0 *default-log-port* "Checking db " dbpath " for errors.") (cond - ((eqv? (dbi:db-dbtype (db:dbdat-get-db dbdat)) 'pg) - #t) ((not (file-write-access? dbdir)) (debug:print 0 *default-log-port* "WARNING: can't write to " dbdir ", can't fix " fname) #f) ;; handle special cases, megatest.db and monitor.db @@ -561,11 +594,11 @@ "megatest -import-megatest.db;megatest -cleanup-db") "\"\n") (exit) ;; we can not safely continue when a db was corrupted - even if fixed. ) ;; test read/write access to the database - (let ((db (dbi:open 'sqlite3 (cons (cons ('dbname dbpath) '()))))) + (let ((db (sqlite3:open-database dbpath))) (cond ((equal? fname "megatest.db") (sqlite3:execute db "DELETE FROM tests WHERE state='DELETED';")) ((equal? fname "main.db") (sqlite3:execute db "DELETE FROM runs WHERE state='deleted';")) @@ -574,11 +607,11 @@ ((equal? fname "monitor.db") (sqlite3:execute "DELETE FROM servers WHERE state LIKE 'defunct%';")) (else (sqlite3:execute db "vacuum;"))) - (sqlite3:finalize! db) + (finalize! db) #t)))))) ;; tbls is ( ("tablename" ( "field1" [#f|proc1] ) ( "field2" [#f|proc2] ) .... ) ) ;; db's are dbdat's ;; @@ -585,73 +618,104 @@ ;; if last-update specified ("field-name" . time-in-seconds) ;; then sync only records where field-name >= time-in-seconds ;; IFF field-name exists ;; (define (db:sync-tables tbls last-update fromdb todb . slave-dbs) - (set! todb (cons (dbi:convert (db:dbdat-get-db todb)) (db:dbdat-get-path todb))) - (set! fromdb (cons (dbi:convert (db:dbdat-get-db fromdb)) (db:dbdat-get-path fromdb))) - (handle-exceptions 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) - (if (not (db:repair-db dbdat)) + (if (not (db:repair-db dbdat)) (begin (debug:print-error 0 *default-log-port* "Failed to rebuild " dbpath ", exiting now.") (exit))))) (cons todb slave-dbs)) 0) ;; this is the work to be done (cond - ((not fromdb) (debug:print 3 *default-log-port* "WARNING: db:sync-tables called with fromdb missing") -1) - ((not todb) (debug:print 3 *default-log-port* "WARNING: db:sync-tables called with todb missing") -2) - ((not (dbi:database? (db:dbdat-get-db fromdb))) - (debug:print-error 0 *default-log-port* "db:sync-tables called with fromdb not a database " fromdb) -3) - ((not (dbi:database? (db:dbdat-get-db todb))) - (debug:print-error 0 *default-log-port* "db:sync-tables called with todb not a database " todb) -4) + ((not fromdb) (debug:print 3 *default-log-port* "WARNING: db:sync-tables called with fromdb missing") + -1) + ((not todb) (debug:print 3 *default-log-port* "WARNING: db:sync-tables called with todb missing") + -2) + ((not (sqlite3:database? (db:dbdat-get-db fromdb))) + (debug:print-error 0 *default-log-port* "db:sync-tables called with fromdb not a database " fromdb) + -3) + ((not (sqlite3:database? (db:dbdat-get-db todb))) + (debug:print-error 0 *default-log-port* "db:sync-tables called with todb not a database " todb) + -4) + + ((not (file-write-access? (db:dbdat-get-path todb))) + (debug:print-error 0 *default-log-port* "db:sync-tables called with todb not a read-only database " todb) + -5) + ((not (null? (let ((readonly-slave-dbs + (filter + (lambda (dbdat) + (not (file-write-access? (db:dbdat-get-path todb)))) + slave-dbs))) + (for-each + (lambda (bad-dbdat) + (debug:print-error + 0 *default-log-port* "db:sync-tables called with todb not a read-only database " bad-dbdat)) + readonly-slave-dbs) + readonly-slave-dbs))) -6) (else (let ((stmts (make-hash-table)) ;; table-field => stmt (all-stmts '()) ;; ( ( stmt1 value1 ) ( stml2 value2 )) (numrecs (make-hash-table)) (start-time (current-milliseconds)) (tot-count 0)) (for-each ;; table (lambda (tabledat) - (let* ((tablename (car tabledat)) - (fields (cdr tabledat)) - (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 '()) (fromdats '()) - (tabletypes '()) (totrecords 0) - (batch-len (string->number (or (configf:lookup *configdat* "sync" "batchsize") "10"))) + (batch-len (string->number (or (configf:lookup *configdat* "sync" "batchsize") "100"))) (todat (make-hash-table)) (count 0)) ;; set up the field->num table (for-each @@ -659,13 +723,13 @@ (hash-table-set! field->num field count) (set! count (+ count 1))) fields) ;; read the source table - (dbi:for-each-row - (lambda (a) - (set! fromdat (cons a fromdat)) + (sqlite3:for-each-row + (lambda (a . b) + (set! fromdat (cons (apply vector a b) fromdat)) (if (> (length fromdat) batch-len) (begin (set! fromdats (cons fromdat fromdats)) (set! fromdat '()) (set! totrecords (+ totrecords 1))))) @@ -678,77 +742,47 @@ (if (common:low-noise-print 120 "sync-records") (debug:print-info 4 *default-log-port* "found " totrecords " records to sync")) ;; read the target table - (dbi:for-each-row - (lambda (a) - (hash-table-set! todat (vector-ref a 0) a)) + (sqlite3:for-each-row + (lambda (a . b) + (hash-table-set! todat a (apply vector a b))) (db:dbdat-get-db todb) full-sel) ;; first pass implementation, just insert all changed rows (for-each (lambda (targdb) - (set! targdb (dbi:convert (db:dbdat-get-db targdb))) - (if (eqv? (dbi:db-dbtype targdb) 'pg) - (let* ((prep "") - (set-stmt "") - (key (car (map car fields))) - (list-fields (map car fields))) - (set! prep (string-intersperse (map cadr fields) ",")) - (set! prep (conc "PREPARE fullupdate (" prep ") AS UPDATE " tablename " SET ")) ;;maybe add lookup in the future depending on where types are needed - (let loop ((i 1)) - (set! set-stmt (conc set-stmt (list-ref list-fields i) " = $" (+ i 1) ", ")) - (if (< i (- (length list-fields) 2)) - (loop (+ i 1)) - (set! set-stmt (conc set-stmt (list-ref list-fields (+ i 1)) " = $" (+ i 2) " WHERE " key " = $1;")))) - (set! full-ins (conc prep set-stmt)))) - (let* ((db (dbi:convert (db:dbdat-get-db targdb))) - (stmth (dbi:prepare db full-ins))) - ;; (db:delay-if-busy targdb) ;; NO WAITING - - (for-each + (let* ((db (db:dbdat-get-db targdb)) + (stmth (sqlite3:prepare db full-ins))) + (db:delay-if-busy targdb) ;; NO WAITING + (for-each (lambda (fromdat-lst) - (dbi:with-transaction + (sqlite3:with-transaction db (lambda () (for-each ;; (lambda (fromrow) (let* ((a (vector-ref fromrow 0)) (curr (hash-table-ref/default todat a #f)) - (same #t) - (res #f) - (len (length (vector->list fromrow)))) + (same #t)) (let loop ((i 0)) (if (or (not curr) (not (equal? (vector-ref fromrow i)(vector-ref curr i)))) (set! same #f)) (if (and same (< i (- num-fields 1))) (loop (+ i 1)))) - (if (eqv? (dbi:db-dbtype db) 'pg) (set! fromrow (list->vector (map (lambda (x) (if (and (string? x) (string-null? x)) (sql-null) x)) (vector->list fromrow))))) - (if (not same) - (begin - (set! res (apply dbi:prepare-exec stmth (vector->list fromrow))) - (hash-table-set! numrecs tablename (+ 1 (hash-table-ref/default numrecs tablename 0))))) - (if (and (not same) (eqv? (dbi:get-res res 'affected-rows) 0)) - (let* ((prep "")) - (set! prep (string-intersperse (map cadr fields) ",")) - (set! prep (conc "INSERT INTO " tablename " ( " (string-intersperse (map car fields) ",") - " ) VALUES ( " (string-intersperse (make-list len "?") ",") " );")) ;;maybe add lookup in the future depending on where types are needed - (begin - (hash-table-set! numrecs tablename (- 1 (hash-table-ref/default numrecs tablename 0))) - (apply dbi:exec db prep (vector->list fromrow)) - (hash-table-set! numrecs tablename (+ 1 (hash-table-ref/default numrecs tablename 0)))))))) - ;;(begin - ;; (dbi:prepare-exec stmth (vector->list fromrow)) - ;;(hash-table-set! numrecs tablename (+ 1 (hash-table-ref/default numrecs tablename 0))))))) + (if (not same) + (begin + (apply sqlite3:execute stmth (vector->list fromrow)) + (hash-table-set! numrecs tablename (+ 1 (hash-table-ref/default numrecs tablename 0))))))) fromdat-lst)) )) fromdats) - (dbi:close stmth))) + (sqlite3:finalize! stmth))) (append (list todb) slave-dbs)))) tbls) (let* ((runtime (- (current-milliseconds) start-time)) (should-print (or (debug:debug-mode 12) (common:low-noise-print 120 "db sync" (> runtime 500))))) ;; low and high sync times treated as separate. @@ -793,18 +827,23 @@ (define (db:patch-schema-maindb maindb) ;; ;; remove all these some time after september 2016 (added in v1.6031 ;; - (handle-exceptions - exn - (if (string-match ".*duplicate.*" ((condition-property-accessor 'exn 'message) exn)) - (debug:print 0 *default-log-port* "Column last_update already added to runs table") - (db:general-sqlite-error-dump exn "alter table runs ..." #f "none")) - (sqlite3:execute - maindb - "ALTER TABLE runs ADD COLUMN last_update INTEGER DEFAULT 0")) + (for-each + (lambda (column type default) + (handle-exceptions + exn + (if (string-match ".*duplicate.*" ((condition-property-accessor 'exn 'message) exn)) + (debug:print 0 *default-log-port* "Column " column " already added to runs table") + (db:general-sqlite-error-dump exn "alter table runs ..." #f "none")) + (sqlite3:execute + maindb + (conc "ALTER TABLE runs ADD COLUMN " column " " type " DEFAULT " default)))) + (list "last_update" "contour") + (list "INTEGER" "TEXT" ) + (list "0" "''" )) ;; these schema changes don't need exception handling (sqlite3:execute maindb "CREATE TRIGGER IF NOT EXISTS update_runs_trigger AFTER UPDATE ON runs FOR EACH ROW @@ -822,12 +861,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)) @@ -845,11 +922,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)) @@ -859,224 +936,158 @@ (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 ;; 'adj-testids - move test-ids into correct ranges -;; 'old2new - sync megatest.db records to .db/{main,1,2 ...}.db -;; 'new2old - sync .db/{main,1,2,3 ...}.db to megatest.db +;; 'old2new - sync megatest.db to /tmp/.../megatest.db and /tmp/.../megatest_ref.db +;; 'new2old - sync /tmp/.../megatest.db to megatest.db and /tmp/.../megatest_ref.db (and update data_synced) ;; 'closeall - close all opened dbs ;; 'schema - attempt to apply schema changes -;; ;; run-ids: '(1 2 3 ...) or #f (for all) ;; (define (db:multi-db-sync dbstruct . options) - (if (not (launch:setup)) - (debug:print 0 *default-log-port* "ERROR: not able to setup up for megatest.") - (let* ((mtdb (dbr:dbstruct-mtdb dbstruct)) - (tmpdb (db:get-db dbstruct)) - (refndb (dbr:dbstruct-refndb dbstruct)) - (slave-dbs (dbr:dbstruct-slave-dbs dbstruct)) - (allow-cleanup #t) ;; (if run-ids #f #t)) - ;; (tdbdat (tasks:open-db)) - (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 - (db:sync-tables (db:sync-all-tables-list dbstruct) #f mtdb tmpdb refndb)) - ;; (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))) - - (if (member 'synctoconfig options) - (if (configf:get-section *configdat* "ext-sync") - (let* ((dblist (configf:get-section *configdat* "ext-sync")) - (res '()) - (cfgdb #f)) - (for-each (lambda (dbitem) - (let* ((stringsplit (string-split (cadr dbitem))) - (dbtype (string->symbol (car stringsplit))) - (dbpath (cadr stringsplit))) - (case dbtype - ((sqlite3) - (set! cfgdb (dbi:open dbtype (cons (cons 'dbname dbpath) '()) )) - (db:initialize-main-db (dbi:db-conn cfgdb)) - (db:initialize-run-id-db (dbi:db-conn cfgdb)) - (set! res (cons (cons cfgdb dbpath) res))) - ((pg) - (let* ((dbinfo '())) - (for-each - (lambda (x) - (if (not (eqv? (string->symbol x) dbtype)) - (let* ((pair (string-split x ":"))) - (if (not (eqv? pair '())) - (set! dbinfo (cons (cons (string->symbol (car pair)) (cadr pair)) dbinfo)))))) - stringsplit) - (set! cfgdb (dbi:open dbtype dbinfo)) - (set! res (cons (cons cfgdb (alist-ref 'host dbinfo)) res)) - ))))) - dblist) - (for-each (lambda (todb) - (db:sync-tables (db:sync-all-tables-list dbstruct) #f mtdb todb)) res) - - ))) - - ;; 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 - (+ (apply db:sync-tables (db:sync-all-tables-list dbstruct) #f tmpdb refndb mtdb slave-dbs) - data-synced))) - - - (if (member 'fixschema 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...") @@ -1105,11 +1116,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)) @@ -1120,21 +1131,23 @@ ;; open-run-close-no-exception-handling ;; open-run-close-exception-handling) ;;) (define (db:initialize-main-db dbdat) + (when (not *configinfo*) + (launch:setup)) ;; added because Elena was getting stack dump because *configinfo* below was #f. (let* ((configdat (car *configinfo*)) ;; tut tut, global warning... (keys (keys:config-get-fields configdat)) (havekeys (> (length keys) 0)) (keystr (keys->keystr keys)) - (fieldstr (keys->key/field keys)) + (fieldstr (keys:make-key/field-string configdat)) (db (db:dbdat-get-db dbdat))) (for-each (lambda (key) (let ((keyn key)) (if (member (string-downcase keyn) (list "runname" "state" "status" "owner" "event_time" "comment" "fail_count" - "pass_count")) + "pass_count" "contour")) (begin (print "ERROR: your key cannot be named " keyn " as this conflicts with the same named field in the runs table, you must remove your megatest.db and /.db before trying again.") (exit 1))))) keys) (sqlite3:with-transaction @@ -1146,10 +1159,11 @@ keys) (sqlite3:execute db (conc "CREATE TABLE IF NOT EXISTS runs (id INTEGER PRIMARY KEY, \n " fieldstr (if havekeys "," "") " runname TEXT DEFAULT 'norun', + contour TEXT DEFAULT '', state TEXT DEFAULT '', status TEXT DEFAULT '', owner TEXT DEFAULT '', event_time TIMESTAMP DEFAULT (strftime('%s','now')), comment TEXT DEFAULT '', @@ -1234,21 +1248,21 @@ 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 + (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, @@ -1268,18 +1282,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);") - (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', @@ -1286,18 +1300,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, @@ -1306,34 +1320,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 ;;====================================================================== @@ -1365,10 +1379,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 ;; @@ -1421,11 +1436,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) @@ -1466,11 +1483,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) @@ -1622,11 +1639,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)))) @@ -1633,11 +1650,11 @@ (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 "COMPLETE" "DEAD" "Test failed to complete")) + (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 all-ids)))))))) ;; ALL REPLACED BY THE BLOCK ABOVE ;; ;; (sqlite3:execute @@ -1689,10 +1706,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 () @@ -1840,10 +1861,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 @@ -1866,14 +1964,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)) @@ -1935,27 +2038,28 @@ ;; register a test run with the db, this accesses the main.db and does NOT ;; use server api ;; -(define (db:register-run dbstruct keyvals runname state status user) +(define (db:register-run dbstruct keyvals runname state status user contour-in) (let* ((keys (map car keyvals)) - (keystr (keys->keystr keys)) + (keystr (keys->keystr keys)) + (contour (or contour-in "")) ;; empty string to force no hierarcy and be backwards compatible. (comma (if (> (length keys) 0) "," "")) (andstr (if (> (length keys) 0) " AND " "")) (valslots (keys->valslots keys)) ;; ?,?,? ... - (allvals (append (list runname state status user) (map cadr keyvals))) + (allvals (append (list runname state status user contour) (map cadr keyvals))) (qryvals (append (list runname) (map cadr keyvals))) (key=?str (string-intersperse (map (lambda (k)(conc k "=?")) keys) " AND "))) (debug:print 3 *default-log-port* "keys: " keys " allvals: " allvals " keyvals: " keyvals " key=?str is " key=?str) (debug:print 2 *default-log-port* "NOTE: using target " (string-intersperse (map cadr keyvals) "/") " for this run") (if (and runname (null? (filter (lambda (x)(not x)) keyvals))) ;; there must be a better way to "apply and" (db:with-db dbstruct #f #f (lambda (db) (let ((res #f)) - (apply sqlite3:execute db (conc "INSERT OR IGNORE INTO runs (runname,state,status,owner,event_time" comma keystr ") VALUES (?,?,?,?,strftime('%s','now')" comma valslots ");") + (apply sqlite3:execute db (conc "INSERT OR IGNORE INTO runs (runname,state,status,owner,event_time,contour" comma keystr ") VALUES (?,?,?,?,strftime('%s','now'),?" comma valslots ");") allvals) (apply sqlite3:for-each-row (lambda (id) (set! res id)) db @@ -2135,18 +2239,22 @@ ;; generate stats from *db-api-call-time* (let ((ordered-keys (sort (hash-table-keys *db-api-call-time*) (lambda (a b) (let ((sum-a (common:sum (hash-table-ref *db-api-call-time* a))) (sum-b (common:sum (hash-table-ref *db-api-call-time* b)))) - (> sum-a sum-b)))))) + (> sum-a sum-b))))) + (total 0)) (for-each (lambda (cmd-key) (let* ((dat (hash-table-ref *db-api-call-time* cmd-key)) - (avg (if (> (length dat) 0) + (num (length dat)) + (avg (if (> num 0) (/ (common:sum dat)(length dat))))) + (set! total (+ total num)) (debug:print-info 0 *default-log-port* cmd-key "\tavg: " avg " max: " (common:max dat) " min: " (common:min-max < dat) " num: " (length dat)))) - ordered-keys))) + ordered-keys) + (debug:print-info 0 *default-log-port* "TOTAL: " total " api calls since start."))) (define (db:get-all-run-ids dbstruct) (db:with-db dbstruct #f @@ -2259,16 +2367,19 @@ db qry-str runnamepatt))))))) ;; use (get-value-by-header (db:get-header runinfo)(db:get-rows runinfo)) +;; NOTE: Does NOT return a list of rows (or one row) for the first slot of the vector +;; this is inconsistent with get-runs but it makes some sense. +;; (define (db:get-run-info dbstruct run-id) ;;(if (hash-table-ref/default *run-info-cache* run-id #f) ;; (hash-table-ref *run-info-cache* run-id) (let* ((res (vector #f #f #f #f)) (keys (db:get-keys dbstruct)) - (remfields (list "id" "runname" "state" "status" "owner" "event_time")) + (remfields (list "id" "runname" "state" "status" "owner" "event_time" "comment" "fail_count" "pass_count" "contour")) ;; "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 @@ -2425,99 +2536,96 @@ ;; not-in #t = above behaviour, #f = must match ;; mode: ;; 'dashboard - use state = 'COMPLETED' AND status in ( statuses ) OR state in ( states ) ;; (define (db:get-tests-for-run dbstruct run-id testpatt states statuses offset limit not-in sort-by sort-order qryvals last-update mode) - (if (not (number? run-id)) - (begin ;; no need to treat this as an error by default - (debug:print 4 *default-log-port* "WARNING: call to db:get-tests-for-run with bad run-id=" run-id) - ;; (print-call-chain (current-error-port)) - '()) - (let* ((qryvalstr (case qryvals - ((shortlist) "id,run_id,testname,item_path,state,status") - ((#f) db:test-record-qry-selector) ;; "id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment") - (else qryvals))) - (res '()) - ;; if states or statuses are null then assume match all when not-in is false - (states-qry (if (null? states) - #f - (conc " state " - (if (eq? mode 'dashboard) - " IN ('" - (if not-in - " NOT IN ('" - " IN ('")) - (string-intersperse states "','") - "')"))) - (statuses-qry (if (null? statuses) - #f - (conc " status " - (if (eq? mode 'dashboard) - " IN ('" - (if not-in - " NOT IN ('" - " IN ('") ) - (string-intersperse statuses "','") - "')"))) - (interim-qry (conc " AND " (if not-in "NOT " "") "( state='COMPLETED' " (if statuses-qry (conc " AND " statuses-qry " ) ") " ) ") - (if states-qry - (conc (if not-in " AND " " OR ") states-qry ) ;; " ) ") - ""))) - (states-statuses-qry - (cond - ((and states-qry statuses-qry) - (case mode - ((dashboard) - (if not-in - (conc " AND (state='COMPLETED' AND status NOT IN ('" (string-intersperse statuses "','") "')) " - " OR (state != 'COMPLETED' AND state NOT IN ('" (string-intersperse states "','") "')) ") - (conc " AND (state='COMPLETED' AND status IN ('" (string-intersperse statuses "','") "')) " - " OR (state NOT IN ('COMPLETED','DELETED') AND state IN ('" (string-intersperse states "','") "')) "))) - (else (conc " AND ( " states-qry " AND " statuses-qry " ) ")))) - (states-qry - (case mode - ((dashboard) (conc " AND " (if not-in "NOT " "") " state IN ('" (string-intersperse states "','") "') ")) ;; interim-qry) - (else (conc " AND " states-qry)))) - (statuses-qry - (case mode - ((dashboard) (conc " AND " (if not-in "NOT " "") " status IN ('" (string-intersperse statuses "','") "') ")) ;; interim-qry) - (else (conc " AND " statuses-qry)))) - (else ""))) - (tests-match-qry (tests:match->sqlqry testpatt)) - (qry (conc "SELECT " qryvalstr + (let* ((qryvalstr (case qryvals + ((shortlist) "id,run_id,testname,item_path,state,status") + ((#f) db:test-record-qry-selector) ;; "id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment") + (else qryvals))) + (res '()) + ;; if states or statuses are null then assume match all when not-in is false + (states-qry (if (null? states) + #f + (conc " state " + (if (eq? mode 'dashboard) + " IN ('" + (if not-in + " NOT IN ('" + " IN ('")) + (string-intersperse states "','") + "')"))) + (statuses-qry (if (null? statuses) + #f + (conc " status " + (if (eq? mode 'dashboard) + " IN ('" + (if not-in + " NOT IN ('" + " IN ('") ) + (string-intersperse statuses "','") + "')"))) + (interim-qry (conc " AND " (if not-in "NOT " "") "( state='COMPLETED' " (if statuses-qry (conc " AND " statuses-qry " ) ") " ) ") + (if states-qry + (conc (if not-in " AND " " OR ") states-qry ) ;; " ) ") + ""))) + (states-statuses-qry + (cond + ((and states-qry statuses-qry) + (case mode + ((dashboard) + (if not-in + (conc " AND (state='COMPLETED' AND status NOT IN ('" (string-intersperse statuses "','") "')) " + " OR (state != 'COMPLETED' AND state NOT IN ('" (string-intersperse states "','") "')) ") + (conc " AND (state='COMPLETED' AND status IN ('" (string-intersperse statuses "','") "')) " + " OR (state NOT IN ('COMPLETED','DELETED') AND state IN ('" (string-intersperse states "','") "')) "))) + (else (conc " AND ( " states-qry " AND " statuses-qry " ) ")))) + (states-qry + (case mode + ((dashboard) (conc " AND " (if not-in "NOT " "") " state IN ('" (string-intersperse states "','") "') ")) ;; interim-qry) + (else (conc " AND " states-qry)))) + (statuses-qry + (case mode + ((dashboard) (conc " AND " (if not-in "NOT " "") " status IN ('" (string-intersperse statuses "','") "') ")) ;; interim-qry) + (else (conc " AND " statuses-qry)))) + (else ""))) + (tests-match-qry (tests:match->sqlqry testpatt)) + (qry (conc "SELECT " qryvalstr + (if run-id " FROM tests WHERE run_id=? " - (if last-update " " " AND state != 'DELETED' ") ;; if using last-update we want deleted tests? - states-statuses-qry - (if tests-match-qry (conc " AND (" tests-match-qry ") ") "") - (if last-update (conc " AND last_update >= " last-update " ") "") - (case sort-by - ((rundir) " ORDER BY length(rundir) ") - ((testname) (conc " ORDER BY testname " (if sort-order (conc sort-order ",") "") " item_path ")) - ((statestatus) (conc " ORDER BY state " (if sort-order (conc sort-order ",") "") " status ")) - ((event_time) " ORDER BY event_time ") - (else (if (string? sort-by) - (conc " ORDER BY " sort-by " ") - " "))) - (if sort-order sort-order " ") - (if limit (conc " LIMIT " limit) " ") - (if offset (conc " OFFSET " offset) " ") - ";" - ))) - (debug:print-info 8 *default-log-port* "db:get-tests-for-run run-id=" run-id ", qry=" qry) - (db:with-db dbstruct run-id #f - (lambda (db) - (sqlite3:for-each-row - (lambda (a . b) ;; id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment) - (set! res (cons (apply vector a b) res))) ;; id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment) res))) - db - qry - run-id - ))) - (case qryvals - ((shortlist)(map db:test-short-record->norm res)) - ((#f) res) - (else res))))) + " FROM tests WHERE ? > 0 ") ;; should work? + (if last-update " " " AND state != 'DELETED' ") ;; if using last-update we want deleted tests? + states-statuses-qry + (if tests-match-qry (conc " AND (" tests-match-qry ") ") "") + (if last-update (conc " AND last_update >= " last-update " ") "") + (case sort-by + ((rundir) " ORDER BY length(rundir) ") + ((testname) (conc " ORDER BY testname " (if sort-order (conc sort-order ",") "") " item_path ")) + ((statestatus) (conc " ORDER BY state " (if sort-order (conc sort-order ",") "") " status ")) + ((event_time) " ORDER BY event_time ") + (else (if (string? sort-by) + (conc " ORDER BY " sort-by " ") + " "))) + (if sort-order sort-order " ") + (if limit (conc " LIMIT " limit) " ") + (if offset (conc " OFFSET " offset) " ") + ";" + ))) + (debug:print-info 8 *default-log-port* "db:get-tests-for-run run-id=" run-id ", qry=" qry) + (db:with-db dbstruct run-id #f + (lambda (db) + (sqlite3:for-each-row + (lambda (a . b) ;; id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment) + (set! res (cons (apply vector a b) res))) ;; id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment) res))) + db + qry + (or run-id 1) ;; 1 > 0 , for the case where we are seeking tests matching criteral for all runs + ))) + (case qryvals + ((shortlist)(map db:test-short-record->norm res)) + ((#f) res) + (else res)))) (define (db:test-short-record->norm inrec) ;; "id,run_id,testname,item_path,state,status" ;; "id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment (vector (vector-ref inrec 0) ;; id @@ -2616,32 +2724,44 @@ ;; (db:delay-if-busy) ;; ;; NB// This call only operates on toplevel tests. Consider replacing it with more general call ;; (define (db:set-tests-state-status dbstruct run-id testnames currstate currstatus newstate newstatus) - (for-each (lambda (testname) - (let ((qry (conc "UPDATE tests SET state=?,status=? WHERE " - (if currstate (conc "state='" currstate "' AND ") "") - (if currstatus (conc "status='" currstatus "' AND ") "") - " run_id=? AND testname LIKE ?;")) - (test-id (db:get-test-id dbstruct run-id testname ""))) - (db:with-db - dbstruct - run-id - #t - (lambda (db) - (sqlite3:execute db qry newstate newstatus run-id testname))) - (if test-id (mt:process-triggers dbstruct run-id test-id newstate newstatus)))) - testnames)) + (let ((test-ids '())) + (for-each + (lambda (testname) + (let ((qry (conc "UPDATE tests SET state=?,status=? WHERE " + (if currstate (conc "state='" currstate "' AND ") "") + (if currstatus (conc "status='" currstatus "' AND ") "") + " run_id=? AND testname LIKE ?;")) + (test-id (db:get-test-id dbstruct run-id testname ""))) + (db:with-db + dbstruct + run-id + #t + (lambda (db) + (sqlite3:execute db qry + (or newstate currstate "NOT_STARTED") + (or newstatus currstate "UNKNOWN") + run-id testname))) + (if test-id + (begin + (set! test-ids (cons test-id test-ids)) + (mt:process-triggers dbstruct run-id test-id newstate newstatus))))) + testnames) + test-ids)) ;; ;; speed up for common cases with a little logic ;; ;; NB// Ultimately this will be deprecated in deference to mt:test-set-state-status-by-id +;; +;; NOTE: run-id is not used ;; ;; (define (db:test-set-state-status dbstruct run-id test-id newstate newstatus newcomment) (db:with-db dbstruct - run-id + ;; run-id + #f #t (lambda (db) (cond ((and newstate newstatus newcomment) (sqlite3:execute db "UPDATE tests SET state=?,status=?,comment=? WHERE id=?;" newstate newstatus newcomment ;; (sdb:qry 'getid newcomment) @@ -2752,11 +2872,12 @@ run-id #f (lambda (db) (sqlite3:first-result db - "SELECT count(id) FROM tests WHERE state in ('LAUNCHED','NOT_STARTED','REMOTEHOSTSTART','RUNNING','KILLREQ');")))) + "SELECT count(id) FROM tests WHERE state in ('LAUNCHED','NOT_STARTED','REMOTEHOSTSTART','RUNNING','KILLREQ') AND run_id=?;") + run-id))) ;; map run-id, testname item-path to test-id (define (db:get-test-id dbstruct run-id testname item-path) (db:with-db dbstruct @@ -2833,20 +2954,20 @@ (define (db:replace-test-records dbstruct run-id testrecs) (db:with-db dbstruct run-id #t (lambda (db) (let* ((qmarks (string-intersperse (make-list (length db:test-record-fields) "?") ",")) - (qrystr (conc "INSERT OR REPLACE INTO tests (" db:test-record-qry-selector ") VALUES (" qmarks ");")) + (qrystr (conc "INSERT OR REPLACE INTO tests (" db:test-record-qry-selector ") VALUES (" qmarks ") WHERE run_id=?;")) (qry (sqlite3:prepare db qrystr))) (debug:print 0 *default-log-port* "INFO: migrating test records for run with id " run-id) (sqlite3:with-transaction db (lambda () (for-each (lambda (rec) ;; (debug:print 0 *default-log-port* "INFO: Inserting values: " (string-intersperse (map conc (vector->list rec)) ",") "\n") - (apply sqlite3:execute qry (vector->list rec))) + (apply sqlite3:execute qry (append (vector->list rec)(list run-id)))) testrecs))) (sqlite3:finalize! qry))))) ;; map a test-id into the proper range ;; @@ -2888,21 +3009,22 @@ (lambda (run-id) (let ((testrecs (db:get-all-tests-info-by-run-id mtdb run-id))) (db:prep-megatest.db-adj-test-ids (db:dbdat-get-db mtdb) run-id testrecs))) run-ids))) -;; Get test data using test_id +;; Get test data using test_id, run-id is not used +;; (define (db:get-test-info-by-id dbstruct run-id test-id) (db:with-db dbstruct - run-id + #f ;; run-id #f (lambda (db) (let ((res #f)) (sqlite3:for-each-row ;; attemptnum added to hold pid of top process (not Megatest) controlling a test (lambda (id run-id testname state status event-time host cpuload diskfree uname rundir-id item-path run_duration final-logf-id comment short-dir-id attemptnum archived) - ;; 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 + ;; 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 (set! res (vector id run-id testname state status event-time host cpuload diskfree uname rundir-id item-path run_duration final-logf-id comment short-dir-id attemptnum archived))) db (conc "SELECT " db:test-record-qry-selector " FROM tests WHERE id=?;") test-id) res)))) @@ -3076,12 +3198,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 @@ -3182,10 +3304,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 ;;====================================================================== @@ -3301,20 +3438,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 @@ -3322,11 +3463,11 @@ (let ((tr-res (sqlite3:with-transaction db (lambda () ;; NB// Pass the db so it is part fo the transaction - (db:test-set-state-status db run-id test-id state status comment) + (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 (running (length (filter (lambda (x) (member (dbr:counts-state x) *common:running-states*)) state-status-counts))) @@ -3333,33 +3474,60 @@ (bad-not-started (length (filter (lambda (x) (and (equal? (dbr:counts-state x) "NOT_STARTED") (not (member (dbr:counts-status x) *common:not-started-ok-statuses*)))) state-status-counts))) - (all-curr-states (common:special-sort ;; worst -> best (sort of) - (delete-duplicates - (cons state (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))) - *common:std-statuses* >)) - (newstate (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)))) + ;; (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 + (if (not (equal? state "DELETED")) + (cons state (map dbr:counts-state state-status-counts)) + (map dbr:counts-state state-status-counts))) + *common:std-states* >)) + (all-curr-statuses (common:special-sort ;; worst -> best + (delete-duplicates + (if (not (equal? state "DELETED")) + (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"))) + all-curr-states)) + (num-non-completes (length non-completes)) + + (newstate (cond + ((> running 0) + "RUNNING") ;; anything running, call the situation running + ((> bad-not-started 0) ;; we have an ugly situation, it is completed in the sense we cannot do more. + "COMPLETED") + ((> 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 (or (> bad-not-started 0) + (and (equal? newstate "NOT_STARTED") + (> num-non-completes 0))) + "STARTED" + (car all-curr-statuses)))) + ;; (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))))))) + (if tl-test-id + (db:test-set-state-status db run-id tl-test-id newstate newstatus #f)))))))) (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))))) - +;; 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) (db:with-db dbstruct #f #f (lambda (db) (sqlite3:map-row @@ -3448,11 +3616,12 @@ SET fail_count=(SELECT count(id) FROM tests WHERE testname=? AND item_path != '' AND status IN ('FAIL','CHECK','INCOMPLETE','ABORT')), pass_count=(SELECT count(id) FROM tests WHERE testname=? AND item_path != '' AND status IN ('PASS','WARN','WAIVED')) WHERE testname=? AND item_path='' AND run_id=?;") ;; DONE ;; BROKEN!!! NEEDS run-id '(top-test-set-running "UPDATE tests SET state='RUNNING' WHERE testname=? AND item_path='' AND run_id=?;") ;; DONE ;; BROKEN!!! NEEDS run-id - + ;; NOT USED + ;; ;; Might be the following top-test-set-per-pf-counts query could be better based off of something like this: ;; ;; select state,status,count(state) from tests where run_id=59 AND testname='runfirst' group by state,status; ;; '(top-test-set-per-pf-counts "UPDATE tests @@ -3704,11 +3873,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) @@ -3741,12 +3910,13 @@ (lambda (db) (sqlite3:for-each-row (lambda (id itempath state status run_duration logf comment) (set! res (cons (vector id itempath state status run_duration logf comment) res))) db - "SELECT id,item_path,state,status,run_duration,final_logf,comment FROM tests WHERE testname=? AND item_path != '';" - test-name) + "SELECT id,item_path,state,status,run_duration,final_logf,comment FROM tests WHERE testname=? AND item_path != '' AND run_id=?;" ;; BUG! WHY NO run_id? + test-name + run-id) res)))) ;;====================================================================== ;; Tests meta data ;;====================================================================== @@ -3874,77 +4044,126 @@ ;; if prereq test with itempath=ref-item-path and COMPLETED with PASS, WARN, CHECK, or WAIVED then prereq is met ;; ;; Note: mode 'normal means that tests must be COMPLETED and ok (i.e. PASS, WARN, CHECK, SKIP or WAIVED) ;; mode 'toplevel means that tests must be COMPLETED only ;; mode 'itemmatch or 'itemwait means that tests items must be COMPLETED and (PASS|WARN|WAIVED|CHECK) [[ NB// NOT IMPLEMENTED YET ]] +;; mode 'exclusive means this test/item cannot run if the same test/item is LAUNCHED,REMOTEHOSTSTART or RUNNING ;; ;; (define (db:get-prereqs-not-met dbstruct run-id waitons ref-item-path mode) (define (db:get-prereqs-not-met dbstruct run-id waitons ref-test-name ref-item-path mode itemmaps) ;; #!key (mode '(normal))(itemmap #f)) - (if (or (not waitons) - (null? waitons)) - '() - (let* ((unmet-pre-reqs '()) - (result '())) - (for-each - (lambda (waitontest-name) - ;; by getting the tests with matching name we are looking only at the matching test - ;; and related sub items - ;; next should be using mt:get-tests-for-run? - (let ((tests (db:get-tests-for-run-state-status dbstruct run-id waitontest-name)) - (ever-seen #f) - (parent-waiton-met #f) - (item-waiton-met #f)) - (for-each - (lambda (test) - ;; (if (equal? waitontest-name (db:test-get-testname test)) ;; by defintion this had better be true ... - (let* ((state (db:test-get-state test)) - (status (db:test-get-status test)) - (item-path (db:test-get-item-path test)) - (is-completed (equal? state "COMPLETED")) - (is-running (equal? state "RUNNING")) - (is-killed (equal? state "KILLED")) - (is-ok (member status '("PASS" "WARN" "CHECK" "WAIVED" "SKIP"))) - ;; testname-b path-a path-b - (same-itempath (db:compare-itempaths ref-test-name item-path ref-item-path itemmaps))) ;; (equal? ref-item-path item-path))) - (set! ever-seen #t) - (cond - ;; case 1, non-item (parent test) is - ((and (equal? item-path "") ;; this is the parent test of the waiton being examined - is-completed - (or is-ok (not (null? (lset-intersection eq? mode '(toplevel)))))) ;; itemmatch itemwait)))))) - (set! parent-waiton-met #t)) - ;; Special case for toplevel and KILLED - ((and (equal? item-path "") ;; this is the parent test - is-killed - (member 'toplevel mode)) - (set! parent-waiton-met #t)) - ;; For itemwait mode IFF the previous matching item is good the set parent-waiton-met - ((and (not (null? (lset-intersection eq? mode '(itemmatch itemwait)))) ;; how is that different from (member mode '(itemmatch itemwait)) ????? - ;; (not (equal? item-path "")) ;; this applies to both top level (to allow launching of next batch) and items - same-itempath) - (if (and is-completed is-ok) - (set! item-waiton-met #t)) - (if (and (equal? item-path "") - (or is-completed is-running));; this is the parent, set it to run if completed or running - (set! parent-waiton-met #t))) - ;; normal checking of parent items, any parent or parent item not ok blocks running - ((and is-completed - (or is-ok - (member 'toplevel mode)) ;; toplevel does not block on FAIL - (and is-ok (member 'itemmatch mode))) ;; itemmatch blocks on not ok - (set! item-waiton-met #t))))) - tests) - ;; both requirements, parent and item-waiton must be met to NOT add item to - ;; prereq's not met list - (if (not (or parent-waiton-met item-waiton-met)) - (set! result (append (if (null? tests) (list waitontest-name) tests) result))) - ;; if the test is not found then clearly the waiton is not met... - ;; (if (not ever-seen)(set! result (cons waitontest-name result))))) - (if (not ever-seen) - (set! result (append (if (null? tests)(list waitontest-name) tests) result))))) - waitons) - (delete-duplicates result)))) + ;; BBnote - rollup of an itemized test's overall state/status done in db:set-state-status-and-roll-up-items + (append + (if (member 'exclusive mode) + (let ((running-tests (db:get-tests-for-run dbstruct + #f ;; run-id of #f means for all runs. + (if (string=? ref-item-path "") ;; testpatt + ref-test-name + (conc ref-test-name "/" ref-item-path)) + '("LAUNCHED" "REMOTEHOSTSTART" "RUNNING") ;; states + '() ;; statuses + #f ;; offset + #f ;; limit + #f ;; not-in + #f ;; sort by + #f ;; sort order + 'shortlist ;; query type + 0 ;; last update, beginning of time .... + #f ;; mode + ))) + ;;(map (lambda (testdat) + ;; (if (equal? (db:test-get-item-path testdat) "") + ;; (db:test-get-testname testdat) + ;; (conc (db:test-get-testname testdat) + ;; "/" + ;; (db:test-get-item-path testdat)))) + running-tests) ;; calling functions want the entire data + '()) + (if (or (not waitons) + (null? waitons)) + '() + (let* ((unmet-pre-reqs '()) + (result '())) + (for-each + (lambda (waitontest-name) + ;; by getting the tests with matching name we are looking only at the matching test + ;; and related sub items + ;; next should be using mt:get-tests-for-run? + (let ((tests (db:get-tests-for-run-state-status dbstruct run-id waitontest-name)) + (ever-seen #f) + (parent-waiton-met #f) + (item-waiton-met #f)) + (for-each + (lambda (test) ;; BB- this is the upstream 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)) ;; BB- this is the upstream itempath + (is-completed (equal? state "COMPLETED")) + (is-running (equal? state "RUNNING")) + (is-killed (equal? state "KILLED")) + (is-ok (member status '("PASS" "WARN" "CHECK" "WAIVED" "SKIP"))) + ;; testname-b path-a path-b + (same-itempath (db:compare-itempaths ref-test-name item-path ref-item-path itemmaps))) ;; (equal? ref-item-path item-path))) + (set! ever-seen #t) + (cond + ;; case 1, non-item (parent test) is + ((and (equal? item-path "") ;; this is the parent test of the waiton being examined + is-completed + (or is-ok (not (null? (lset-intersection eq? mode '(toplevel)))))) ;; itemmatch itemwait)))))) + (set! parent-waiton-met #t)) + ;; Special case for toplevel and KILLED + ((and (equal? item-path "") ;; this is the parent test + is-killed + (member 'toplevel mode)) + (set! parent-waiton-met #t)) + ;; For itemwait mode IFF the previous matching item is good the set parent-waiton-met + ((and (not (null? (lset-intersection eq? mode '(itemmatch itemwait)))) ;; how is that different from (member mode '(itemmatch itemwait)) ????? + ;; (not (equal? item-path "")) ;; this applies to both top level (to allow launching of next batch) and items + same-itempath) + (if (and is-completed is-ok) + (set! item-waiton-met #t)) + (if (and (equal? item-path "") ;; if upstream rollup test is completed, parent-waiton-met is set + (or is-completed is-running));; this is the parent, set it to run if completed or running ;; BB1 + (set! parent-waiton-met #t))) + ;; normal checking of parent items, any parent or parent item not ok blocks running + ((and is-completed + (or is-ok + (member 'toplevel mode)) ;; toplevel does not block on FAIL + (and is-ok (member 'itemmatch mode))) ;; itemmatch blocks on not ok + (set! item-waiton-met #t))))) + tests) + ;; both requirements, parent and item-waiton must be met to NOT add item to + ;; prereq's not met list + (if (not (or parent-waiton-met item-waiton-met)) + (set! result (append (if (null? tests) (list waitontest-name) tests) result))) ;; 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))))) + waitons) + (delete-duplicates result))))) + +;;====================================================================== +;; Just for sync, procedures to make sync easy +;;====================================================================== + +;; get an alist of record ids changed since time since-time +;; '((runs . (1 2 3 ...))(steps . (5 6 7 ...) ...)) +;; +(define (db:get-changed-record-ids dbstruct since-time) + ;; no transaction, allow the db to be accessed between the big queries + (let ((backcons (lambda (lst item)(cons item lst)))) + (db:with-db + dbstruct #f #f + (lambda (db) + `((runs . ,(fold-row backcons '() db "SELECT id FROM runs WHERE last_update>?" since-time)) + (tests . ,(fold-row backcons '() db "SELECT id FROM tests WHERE last_update>?" since-time)) + (test_steps . ,(fold-row backcons '() db "SELECT id FROM test_steps WHERE last_update>?" since-time)) + (test_data . ,(fold-row backcons '() db "SELECT id FROM test_data WHERE last_update>?" since-time)) + ;; (test_meta . ,(fold-row backcons '() db "SELECT id FROM test_meta WHERE last_update>?" since-time)) + (run_stats . ,(fold-row backcons '() db "SELECT id FROM run_stats WHERE last_update>?" since-time)) + ))))) ;;====================================================================== ;; Extract ods file from the db ;;====================================================================== @@ -4019,12 +4238,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))) @@ -4067,10 +4286,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: dcommon.scm ================================================================== --- dcommon.scm +++ dcommon.scm @@ -19,11 +19,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 +85,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))) @@ -491,11 +491,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"))) @@ -609,12 +609,11 @@ (iup:vbox ;; (iup:label "Run statistics" #:expand "HORIZONTAL") stats-matrix))) (define (dcommon:servers-table commondat tabdat) - (let* ((tdbdat (tasks:open-db)) - (colnum 0) + (let* ((colnum 0) (rownum 0) (servers-matrix (iup:matrix #:expand "YES" #:numcol 7 #:numcol-visible 7 #:numlin-visible 5 @@ -621,11 +620,10 @@ )) (colnames (list "Id" "MTver" "Pid" "Host" "Interface:OutPort" "RunTime" "State" "RunId")) (updater (lambda () (if (dashboard:monitor-changed? commondat tabdat) (let ((servers (server:get-list *toppath* limit: 10))) - ;; (tasks:get-all-servers (db:delay-if-busy tdbdat)))) (iup:attribute-set! servers-matrix "NUMLIN" (length servers)) ;; (set! colnum 0) ;; (for-each (lambda (colname) ;; ;; (print "colnum: " colnum " colname: " colname) ;; (iup:attribute-set! servers-matrix (conc "0:" colnum) colname) @@ -1187,11 +1185,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) @@ -1282,5 +1280,16 @@ (loop next-row next-col #t)) (if (eq? colnum max-col) ;; not done, didn't get a full blank row (if deleted (loop next-row next-col #f)) ;; exit on this not met (loop next-row next-col deleted))))) (iup:attribute-set! steps-matrix "REDRAW" "ALL"))))) + +;;====================================================================== +;; U T I L I T I E S +;;====================================================================== + +(define (dcommon:run-html-viewer lfilename) + (let ((htmlviewercmd (configf:lookup *configdat* "setup" "htmlviewercmd"))) + (if htmlviewercmd + (system (conc "(" htmlviewercmd " " lfilename " ) &")) + (iup:send-url lfilename)))) + Index: docs/api.html ================================================================== --- docs/api.html +++ docs/api.html @@ -1015,10 +1015,10 @@

ADDED docs/api_access_methods_evolution.ods Index: docs/api_access_methods_evolution.ods ================================================================== --- /dev/null +++ docs/api_access_methods_evolution.ods cannot compute difference between binary files 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 @@ -876,24 +875,24 @@

Goals

Reduce load on the file system. Sqlite3 files on network filesystem can be - a burden. + a burden. [DONE]
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]
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]
Reduce number of processes involved in managing running tests. @@ -905,35 +904,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 +946,32 @@
  ww05 - migrate to inmem-db
  -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]
  
  Server polls tasks table for next action
  
  -Task table used for tracking runner process [DONE] +Task table used for tracking runner process [Replaced by mtutil]
  
  -Task table used for jobs to run +Task table used for jobs to run [Replaced by mtutil]
  
  -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 +1415,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:

@@ -1489,10 +1509,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

@@ -1893,11 +1922,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 +1936,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 +1952,78 @@
 
 
 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 @@ -2011,11 +2108,11 @@

These routines can be called from the megatest repl.

- + @@ -2063,10 +2160,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 Index: docs/manual/reference.txt ================================================================== --- docs/manual/reference.txt +++ docs/manual/reference.txt @@ -42,15 +42,38 @@ 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: @@ -122,10 +145,22 @@ .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 ++++++++++++++ ----------------- @@ -447,11 +482,11 @@ ---------------------------- 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 @@ -462,11 +497,11 @@ # 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: @@ -474,10 +509,33 @@ [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 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Index: docs/megatest-state-status.dot ================================================================== --- docs/megatest-state-status.dot +++ docs/megatest-state-status.dot @@ -31,11 +31,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"]; Index: docs/plan.txt ================================================================== --- docs/plan.txt +++ docs/plan.txt @@ -8,44 +8,45 @@ Goals ^^^^^ . Reduce load on the file system. Sqlite3 files on network filesystem can be - a burden. + 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". + 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. + 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. + second max delay. [green]#[DONE]# . Read/writes to db for processes on homehost will go direct to /tmp - megatest.db file. + 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. -. Db syncs rely on the target db file timestame minus some margin. + 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. + 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 [DONE] +. 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 [DONE] -.. Task table used for jobs to run -.. Task table used for queueing runner actions (remove runs, cleanRunExecute, etc) +.. 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 // ~~~~ // ADDED emergency-patches/emergency-patch-1.scm Index: emergency-patches/emergency-patch-1.scm ================================================================== --- /dev/null +++ emergency-patches/emergency-patch-1.scm @@ -0,0 +1,203 @@ + + +;; These are called by the server on recipt of /api calls +;; - keep it simple, only return the actual result of the call, i.e. no meta info here +;; +;; - returns #( flag result ) +;; +(define (api:execute-requests dbstruct dat) + (handle-exceptions + exn + (let ((call-chain (get-call-chain))) + (debug:print 0 *default-log-port* "WARNING: api:execute-requests received an exception from peer, dat=" dat) + (print-call-chain (current-error-port)) + (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) + (vector #f (vector exn call-chain dat))) ;; return some stuff for debug if an exception happens + (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 + (string->symbol cmd-in))) + (params (vector-ref dat 1)) + (start-t (current-milliseconds)) + (readonly-mode (dbr:dbstruct-read-only dbstruct)) + (readonly-command (member cmd api:read-only-queries)) + (writecmd-in-readonly-mode (and readonly-mode (not readonly-command))) + (res + (if writecmd-in-readonly-mode + (conc "attempt to run write command "cmd" on a read-only database") + (case cmd + ;;=============================================== + ;; READ/WRITE QUERIES + ;;=============================================== + + ((get-keys-write) (db:get-keys dbstruct)) ;; force a dummy "write" query to force server; for debug in -repl + + ;; SERVERS + ((start-server) (apply server:kind-run params)) + ((kill-server) (set! *server-run* #f)) + + ;; TESTS + + ;;((test-set-state-status-by-id) (apply mt:test-set-state-status-by-id dbstruct params)) + ;;BB - commented out above because it was calling below, eventually, incorrectly (dbstruct passed to mt:test-set-state-status-by-id, which previosly did more, but now only passes thru to db:set-state-status-and-roll-up-items. + ((test-set-state-status-by-id) + + ;; (define (db:set-state-status-and-roll-up-items dbstruct run-id test-name item-path state status comment) + (db:set-state-status-and-roll-up-items + dbstruct + (list-ref params 0) ; run-id + (list-ref params 1) ; test-name + #f ; item-path + (list-ref params 2) ; state + (list-ref params 3) ; status + (list-ref params 4) ; comment + )) + + ((delete-test-records) (apply db:delete-test-records dbstruct params)) + ((delete-old-deleted-test-records) (apply db:delete-old-deleted-test-records dbstruct params)) + ((test-set-state-status) (apply db:test-set-state-status dbstruct params)) + ((test-set-top-process-pid) (apply db:test-set-top-process-pid dbstruct params)) + ((set-state-status-and-roll-up-items) (apply db:set-state-status-and-roll-up-items dbstruct params)) + ((top-test-set-per-pf-counts) (apply db:top-test-set-per-pf-counts dbstruct params)) + ((test-set-archive-block-id) (apply db:test-set-archive-block-id dbstruct params)) + + ;; RUNS + ((register-run) (apply db:register-run dbstruct params)) + ((set-tests-state-status) (apply db:set-tests-state-status dbstruct params)) + ((delete-run) (apply db:delete-run dbstruct params)) + ((lock/unlock-run) (apply db:lock/unlock-run dbstruct params)) + ((update-run-event_time) (apply db:update-run-event_time dbstruct params)) + ((update-run-stats) (apply db:update-run-stats dbstruct params)) + ((set-var) (apply db:set-var dbstruct params)) + ((del-var) (apply db:del-var dbstruct params)) + + ;; STEPS + ((teststep-set-status!) (apply db:teststep-set-status! dbstruct params)) + + ;; TEST DATA + ((test-data-rollup) (apply db:test-data-rollup dbstruct params)) + ((csv->test-data) (apply db:csv->test-data dbstruct params)) + + ;; MISC + ((sync-inmem->db) (let ((run-id (car params))) + (db:sync-touched dbstruct run-id force-sync: #t))) + ((mark-incomplete) (apply db:find-and-mark-incomplete dbstruct params)) + + ;; TESTMETA + ((testmeta-add-record) (apply db:testmeta-add-record dbstruct params)) + ((testmeta-update-field) (apply db:testmeta-update-field dbstruct params)) + ((get-tests-tags) (db:get-tests-tags dbstruct)) + + ;; TASKS + ((tasks-add) (apply tasks:add dbstruct params)) + ((tasks-set-state-given-param-key) (apply tasks:set-state-given-param-key dbstruct params)) + ((tasks-get-last) (apply tasks:get-last dbstruct params)) + + ;; NO SYNC DB + ((no-sync-set) (apply db:no-sync-set *no-sync-db* params)) + ((no-sync-get/default) (apply db:no-sync-get/default *no-sync-db* params)) + ((no-sync-del!) (apply db:no-sync-del! *no-sync-db* params)) + + ;; ARCHIVES + ;; ((archive-get-allocations) + ((archive-register-disk) (apply db:archive-register-disk dbstruct params)) + ((archive-register-block-name)(apply db:archive-register-block-name dbstruct params)) + ((archive-allocate-testsuite/area-to-block)(apply db:archive-allocate-testsuite/area-to-block dbstruct block-id testsuite-name areakey)) + + ;;====================================================================== + ;; READ ONLY QUERIES + ;;====================================================================== + + ;; KEYS + ((get-key-val-pairs) (apply db:get-key-val-pairs dbstruct params)) + ((get-keys) (db:get-keys dbstruct)) + ((get-key-vals) (apply db:get-key-vals dbstruct params)) + ((get-target) (apply db:get-target dbstruct params)) + ((get-targets) (db:get-targets dbstruct)) + + ;; ARCHIVES + ((test-get-archive-block-info) (apply db:test-get-archive-block-info dbstruct params)) + + ;; TESTS + ((test-toplevel-num-items) (apply db:test-toplevel-num-items dbstruct params)) + ((get-test-info-by-id) (apply db:get-test-info-by-id dbstruct params)) + ((test-get-rundir-from-test-id) (apply db:test-get-rundir-from-test-id dbstruct params)) + ((get-count-tests-running-for-testname) (apply db:get-count-tests-running-for-testname dbstruct params)) + ((get-count-tests-running) (apply db:get-count-tests-running dbstruct params)) + ((get-count-tests-running-in-jobgroup) (apply db:get-count-tests-running-in-jobgroup dbstruct params)) + ;; ((delete-test-step-records) (apply db:delete-test-step-records dbstruct params)) + ((get-previous-test-run-record) (apply db:get-previous-test-run-record dbstruct params)) + ((get-matching-previous-test-run-records)(apply db:get-matching-previous-test-run-records dbstruct params)) + ((test-get-logfile-info) (apply db:test-get-logfile-info dbstruct params)) + ((test-get-records-for-index-file) (apply db:test-get-records-for-index-file dbstruct params)) + ((get-testinfo-state-status) (apply db:get-testinfo-state-status dbstruct params)) + ((test-get-top-process-pid) (apply db:test-get-top-process-pid dbstruct params)) + ((test-get-paths-matching-keynames-target-new) (apply db:test-get-paths-matching-keynames-target-new dbstruct params)) + ((get-prereqs-not-met) (apply db:get-prereqs-not-met dbstruct params)) + ((get-count-tests-running-for-run-id) (apply db:get-count-tests-running-for-run-id dbstruct params)) + ((synchash-get) (apply synchash:server-get dbstruct params)) + ((get-raw-run-stats) (apply db:get-raw-run-stats dbstruct params)) + + ;; RUNS + ((get-run-info) (apply db:get-run-info dbstruct params)) + ((get-run-status) (apply db:get-run-status dbstruct params)) + ((set-run-status) (apply db:set-run-status dbstruct params)) + ((get-tests-for-run) (apply db:get-tests-for-run dbstruct params)) + ((get-test-id) (apply db:get-test-id dbstruct params)) + ((get-tests-for-run-mindata) (apply db:get-tests-for-run-mindata dbstruct params)) + ((get-runs) (apply db:get-runs dbstruct params)) + ((get-num-runs) (apply db:get-num-runs dbstruct params)) + ((get-all-run-ids) (db:get-all-run-ids dbstruct)) + ((get-prev-run-ids) (apply db:get-prev-run-ids dbstruct params)) + ((get-run-ids-matching-target) (apply db:get-run-ids-matching-target dbstruct params)) + ((get-runs-by-patt) (apply db:get-runs-by-patt dbstruct params)) + ((get-run-name-from-id) (apply db:get-run-name-from-id dbstruct params)) + ((get-main-run-stats) (apply db:get-main-run-stats dbstruct params)) + ((get-var) (apply db:get-var dbstruct params)) + ((get-run-stats) (apply db:get-run-stats dbstruct params)) + + ;; STEPS + ((get-steps-data) (apply db:get-steps-data dbstruct params)) + ((get-steps-for-test) (apply db:get-steps-for-test dbstruct params)) + + ;; TEST DATA + ((read-test-data) (apply db:read-test-data dbstruct params)) + ((read-test-data*) (apply db:read-test-data* dbstruct params)) + + ;; MISC + ((get-latest-host-load) (apply db:get-latest-host-load dbstruct params)) + ((have-incompletes?) (apply db:have-incompletes? dbstruct params)) + ((login) (apply db:login dbstruct params)) + ((general-call) (let ((stmtname (car params)) + (run-id (cadr params)) + (realparams (cddr params))) + (db:general-call dbstruct stmtname realparams))) + ((sdb-qry) (apply sdb:qry params)) + ((ping) (current-process-id)) + ((get-changed-record-ids) (apply db:get-changed-record-ids dbstruct params)) + + ;; TESTMETA + ((testmeta-get-record) (apply db:testmeta-get-record dbstruct params)) + + ;; TASKS + ((find-task-queue-records) (apply tasks:find-task-queue-records dbstruct params)) + (else + (debug:print 0 *default-log-port* "ERROR: bad api call " cmd) + (conc "ERROR: BAD api call " cmd)))))) + + ;; save all stats + (let ((delta-t (- (current-milliseconds) + start-t))) + (hash-table-set! *db-api-call-time* cmd + (cons delta-t (hash-table-ref/default *db-api-call-time* cmd '())))) + (if writecmd-in-readonly-mode + (vector #f res) + (vector #t res))))))) ADDED emergency-patches/emergency-patch-2.scm Index: emergency-patches/emergency-patch-2.scm ================================================================== --- /dev/null +++ emergency-patches/emergency-patch-2.scm @@ -0,0 +1,311 @@ +(include "common_records.scm") +(include "key_records.scm") +(include "db_records.scm") +(include "run_records.scm") +(include "test_records.scm") + +(define (common:wait-for-cpuload maxload numcpus waitdelay #!key (count 1000) (msg #f)(remote-host #f)) + (let* ((loadavg (common:get-cpu-load remote-host)) + (first (car loadavg)) + (next (cadr loadavg)) + (adjload (* maxload numcpus)) + (loadjmp (- first next))) + (cond + ((and (> first adjload) + (> count 0)) + (debug:print-info 0 *default-log-port* "waiting " waitdelay " seconds due to load " first " exceeding max of " adjload " " (if msg msg "")) + (thread-sleep! waitdelay) + (common:wait-for-cpuload maxload numcpus waitdelay count: (- count 1))) + ((and (> loadjmp numcpus) + (> count 0)) + (debug:print-info 0 *default-log-port* "waiting " waitdelay " seconds due to load jump " loadjmp " > numcpus " numcpus (if msg msg "")) + (thread-sleep! waitdelay) + (common:wait-for-cpuload maxload numcpus waitdelay count: (- count 1)))))) + +(define (common: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: msg remote-host: hh))) + +;; wait for normalized cpu load to drop below maxload +;; +(define (common:wait-for-normalized-load maxload #!key (msg #f)(remote-host #f)) + (let ((num-cpus (common:get-num-cpus remote-host))) + (common:wait-for-cpuload maxload num-cpus 15 msg: msg remote-host: remote-host))) + +;; 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). + (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)) + (item-path (runs:testdat-item-path testdat)) + (jobgroup (runs:testdat-jobgroup testdat)) + (waitons (runs:testdat-waitons testdat)) + (item-path (runs:testdat-item-path testdat)) + (testmode (runs:testdat-testmode testdat)) + (newtal (runs:testdat-newtal testdat)) + (itemmaps (runs:testdat-itemmaps testdat)) + (test-record (runs:testdat-test-record testdat)) + (prereqs-not-met (runs:testdat-prereqs-not-met testdat)) + + (reglen (runs:dat-reglen runsdat)) + (regfull (runs:dat-regfull runsdat)) + (runname (runs:dat-runname runsdat)) + (max-concurrent-jobs (runs:dat-max-concurrent-jobs runsdat)) + (run-id (runs:dat-run-id runsdat)) + (test-patts (runs:dat-test-patts runsdat)) + (required-tests (runs:dat-required-tests runsdat)) + (test-registry (runs:dat-test-registry runsdat)) + (registry-mutex (runs:dat-registry-mutex runsdat)) + (flags (runs:dat-flags runsdat)) + (keyvals (runs:dat-keyvals runsdat)) + (run-info (runs:dat-run-info runsdat)) + (all-tests-registry (runs:dat-all-tests-registry runsdat)) + (run-limits-info (runs:dat-can-run-more-tests runsdat)) + ;; (runs:can-run-more-tests run-id jobgroup max-concurrent-jobs)) ;; look at the test jobgroup and tot jobs running + (have-resources (car run-limits-info)) + (num-running (list-ref run-limits-info 1)) + (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) + (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! + (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.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)) + (conc " WARNING: t is not a vector=" t ))) + prereqs-not-met) + ", ") ") fails: " fails + "\nregistered? " (hash-table-ref/default test-registry (db:test-make-full-name test-name item-path) #f)) + + + + (if (and (not (null? prereqs-not-met)) + (runs:lownoise (conc "waiting on tests " prereqs-not-met hed) 60)) + (debug:print-info 2 *default-log-port* "waiting on tests; " (string-intersperse (runs:mixed-list-testname-and-testrec->list-of-strings prereqs-not-met) ", "))) + + ;; 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 + + ;; 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) + #f)) + + ;; Register tests + ;; + ((not (hash-table-ref/default test-registry (db:test-make-full-name test-name item-path) #f)) + (debug:print-info 4 *default-log-port* "Pre-registering test " test-name "/" item-path " to create placeholder" ) + ;; always do firm registration now in v1.60 and greater ;; (eq? *transport-type* 'fs) ;; no point in parallel registration if use fs + (let register-loop ((numtries 15)) + (rmt:register-test run-id test-name item-path) + (if (rmt:get-test-id run-id test-name item-path) + (hash-table-set! test-registry (db:test-make-full-name test-name item-path) 'done) + (if (> numtries 0) + (begin + (thread-sleep! 0.5) + (register-loop (- numtries 1))) + (debug:print-error 0 *default-log-port* "failed to register test " (db:test-make-full-name test-name item-path))))) + (if (not (eq? (hash-table-ref/default test-registry (db:test-make-full-name test-name "") #f) 'done)) + (begin + (rmt:register-test run-id test-name "") + (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) + (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)) + (append reg (list hed))) + reruns))) + + ;; At this point hed test registration must be completed. + ;; + ((eq? (hash-table-ref/default test-registry (db:test-make-full-name test-name item-path) #f) + 'start) + (debug:print-info 0 *default-log-port* "Waiting on test registration(s): " + (string-intersperse + (filter (lambda (x) + (eq? (hash-table-ref/default test-registry x #f) 'start)) + (hash-table-keys test-registry)) + ", ")) + (thread-sleep! 0.051) + (list hed tal reg reruns)) + + ;; If no resources are available just kill time and loop again + ;; + ((not have-resources) ;; simply try again after waiting a second + (if (runs:lownoise "no resources" 60) + (debug:print-info 1 *default-log-port* "no resources to run new tests, waiting ...")) + ;; Have gone back and forth on this but db starvation is an issue. + ;; wait one second before looking again to run jobs. + (thread-sleep! 1) + ;; could have done hed tal here but doing car/cdr of newtal to rotate tests + (list (car newtal)(cdr newtal) reg reruns)) + + ;; This is the final stage, everything is in place so launch the test + ;; + ((and have-resources + (or (null? prereqs-not-met) + (and (member 'toplevel testmode) ;; 'toplevel) + (null? non-completed) + (not (member 'exclusive testmode))))) + ;; (hash-table-delete! *max-tries-hash* (db:test-make-full-name test-name item-path)) + ;; 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 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) + #f)) + + ;; must be we have unmet prerequisites + ;; + (else + (debug:print 4 *default-log-port* "FAILS: " fails) + ;; If one or more of the prereqs-not-met are FAIL then we can issue + ;; a message and drop hed from the items to be processed. + ;; (runs:mixed-list-testname-and-testrec->list-of-strings prereqs-not-met) + (if (and (not (null? prereqs-not-met)) + (runs:lownoise (conc "waiting on tests " prereqs-not-met hed) 60)) + (debug:print-info 1 *default-log-port* "waiting on tests; " (string-intersperse + (runs:mixed-list-testname-and-testrec->list-of-strings + prereqs-not-met) ", "))) + (if (or (null? fails) + (member 'toplevel testmode)) + (begin + ;; couldn't run, take a breather + (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 + (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"))) + (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) + (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))) + (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) + (and (number? nth-try) + (< nth-try 10))) + (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) + (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)))) + (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) + (mt:test-set-state-status-by-testname run-id test-name item-path "NOT_STARTED" "TEN_STRIKES" #f) + ;; I'm unclear on if this roll up is needed - it may be the root cause of the "all set to FAIL" bug. + (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))))))))) ADDED emergency-patches/emergency-patch-3.scm Index: emergency-patches/emergency-patch-3.scm ================================================================== --- /dev/null +++ emergency-patches/emergency-patch-3.scm @@ -0,0 +1,81 @@ + ;; To build patch: + ;;;;;;;;;;;;;;;;;;;;;;;;; + ;; ldd /p/foundry/env/pkgs/megatest/1.64/19/bin/.11/mtest + ;; linux-vdso.so.1 => (0x00002aaaaaaab000) + ;; libchicken.so.7 => /p/foundry/env/pkgs/megatest/1.64/chicken-4.10.0//lib/libchicken.so.7 (0x00002aaaaaaad000) + ;; libm.so.6 => /lib64/libm.so.6 (0x00002aaaab0a6000) + ;; libdl.so.2 => /lib64/libdl.so.2 (0x00002aaaab31f000) + ;; libc.so.6 => /lib64/libc.so.6 (0x00002aaaab523000) + ;; /lib64/ld-linux-x86-64.so.2 (0x0000555555554000) + ;; + ;; /p/foundry/env/pkgs/megatest/1.64/chicken-4.10.0/bin/csc -s emergency-patch-3.scm + ;; + + + ;; to test patch: + ;;;;;;;;;;;;;;;;;;;;;;;;; + ;; in .megatestrc, add: + ;; (if (and (> megatest-version 1.64) + ;; (< megatest-version 1.6421)) + ;; (begin + ;; (load "/p/foundry/env/pkgs/megatest/1.64/19/share/epatch-1.so") + ;; (load "/p/foundry/env/pkgs/megatest/1.64/19/share/epatch-2.so"))) + ;; + + + ;; to productize patch: + ;;;;;;;;;;;;;;;;;;;;;;;;; + ;; +(use directory-utils regex) + +(include "common_records.scm") +(include "key_records.scm") +(include "db_records.scm") +(include "run_records.scm") +(include "test_records.scm") + +;; Given a run id start a server process ### NOTE ### > file 2>&1 +;; if the run-id is zero and the target-host is set +;; try running on that host +;; incidental: rotate logs in logs/ dir. +;; +(define (server:run areapath) ;; areapath is *toppath* for a given testsuite area + (let* ((curr-host (get-host-name)) + ;; (attempt-in-progress (server:start-attempted? areapath)) + ;; (dot-server-url (server:check-if-running areapath)) + (curr-ip (server:get-best-guess-address curr-host)) + (curr-pid (current-process-id)) + (homehost (common:get-homehost)) ;; configf:lookup *configdat* "server" "homehost" )) + (target-host (car homehost)) + (testsuite (common:get-testsuite-name)) + (logfile (conc areapath "/logs/server.log")) ;; -" curr-pid "-" target-host ".log")) + (cmdln (conc (common:get-megatest-exe) + " -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")) + (load-limit (configf:lookup-number *configdat* "server" "load-limit" default: 0.9))) + ;; 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) + + ;; host.domain.tld match host? + (if (and target-host + ;; look at target host, is it host.domain.tld or ip address and does it + ;; match current ip or hostname + (not (string-match (conc "("curr-host "|" curr-host"\\..*)") target-host)) + (not (equal? curr-ip target-host))) + (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 load-limit " 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 + (system (conc "nbfake " cmdln)) + (unsetenv "TARGETHOST_LOGF") + (if (get-environment-variable "TARGETHOST")(unsetenv "TARGETHOST")) + (thread-join! log-rotate) + (pop-directory))) 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, Index: ezsteps.scm ================================================================== --- ezsteps.scm +++ ezsteps.scm @@ -37,19 +37,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 +75,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) ADDED file-tail.scm Index: file-tail.scm ================================================================== --- /dev/null +++ file-tail.scm @@ -0,0 +1,76 @@ + +(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 (common: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) + (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 + (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: filedb.scm ================================================================== --- filedb.scm +++ filedb.scm @@ -16,11 +16,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)) 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 gentargets.sh Index: gentargets.sh ================================================================== --- /dev/null +++ gentargets.sh @@ -0,0 +1,6 @@ +#!/bin/bash + +echo '[v1.63/tip/dev]' +echo 'x 1' +echo '[v1.64/tip/dev]' +echo 'x 1' 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 @@ -20,24 +20,35 @@ (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)) ((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 +55,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 @@ -57,12 +57,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 (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) @@ -104,48 +107,52 @@ ((equal? (uri-path (request-uri (current-request))) '(/ "hey")) (send-response body: "hey there!\n" headers: '((content-type text/plain)))) (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)) - (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 - (http-transport:try-start-server ipaddrstr - (portlogger:open-run-close portlogger:find-port))) - (begin - (print "ERROR: Tried and tried but could not start the server")))) - ;; any error in following steps will result in a retry - (set! *server-info* (list ipaddrstr portnum)) - (debug:print 0 *default-log-port* "INFO: Trying to start server on " ipaddrstr ":" portnum) - ;; This starts the spiffy server - ;; NEED WAY TO SET IP TO #f TO BIND ALL - ;; (start-server bind-address: ipaddrstr port: portnum) - (if config-hostname ;; this is a hint to bind directly - (start-server port: portnum bind-address: (if (equal? config-hostname "-") - ipaddrstr - config-hostname)) - (start-server port: portnum)) - (portlogger:open-run-close portlogger:set-port portnum "released") - (debug:print 1 *default-log-port* "INFO: server has been stopped")))) + 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 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 + (http-transport:try-start-server ipaddrstr + (portlogger:open-run-close portlogger:find-port))) + (begin + (print "ERROR: Tried and tried but could not start the server")))) + ;; any error in following steps will result in a retry + (set! *server-info* (list ipaddrstr portnum)) + (debug:print 0 *default-log-port* "INFO: Trying to start server on " ipaddrstr ":" portnum) + ;; This starts the spiffy server + ;; NEED WAY TO SET IP TO #f TO BIND ALL + ;; (start-server bind-address: ipaddrstr port: portnum) + (if config-hostname ;; this is a hint to bind directly + (start-server port: portnum bind-address: (if (equal? config-hostname "-") + ipaddrstr + config-hostname)) + (start-server port: portnum)) + (portlogger:open-run-close portlogger:set-port portnum "released") + (debug:print 1 *default-log-port* "INFO: server has been stopped")))) ;;====================================================================== ;; S E R V E R U T I L I T I E S ;;====================================================================== @@ -202,19 +209,20 @@ (mutex-lock! *http-mutex*) (set! *http-requests-in-progress* (+ 1 *http-requests-in-progress*))) ;; Send "cmd" with json payload "params" to serverdat and receive result ;; -(define (http-transport:client-api-send-receive run-id serverdat cmd params #!key (numretries 3)) +(define (http-transport:client-api-send-receive run-id serverdat cmd params #!key (numretries 3)(area-dat #f)) (let* ((fullurl (if (vector? serverdat) (http-transport:server-dat-get-api-req serverdat) (begin (debug:print 0 *default-log-port* "FATAL ERROR: http-transport:client-api-send-receive called with no server info") (exit 1)))) (res (vector #f "uninitialized")) (success #t) - (sparams (db:obj->string params transport: 'http))) + (sparams (db:obj->string params transport: 'http)) + (runremote (or area-dat *runremote*))) (debug:print-info 11 *default-log-port* "fullurl=" fullurl ", cmd=" cmd ", params=" params ", run-id=" run-id "\n") ;; set up the http-client here (max-retry-attempts 1) ;; consider all requests indempotent (retry-request? (lambda (request) @@ -224,34 +232,37 @@ ;; process and return it. (let* ((send-recieve (lambda () (mutex-lock! *http-mutex*) ;; (condition-case (with-input-from-request "http://localhost"; #f read-lines) ;; ((exn http client-error) e (print e))) - (set! res (vector + (set! res (vector ;;; DON'T FORGET - THIS IS THE CLIENT SIDE! NOTE: consider moving this to client.scm since we are only supporting http transport at this time. success (db:string->obj (handle-exceptions - exn - (begin - (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: " ((condition-property-accessor 'exn 'message) exn)) - (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*) + 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) + (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 ;;; (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") - (cons 'cmd cmd) - (cons 'params sparams)) - read-string)) + (db:obj->string #f)) + (with-input-from-request ;; was dat + fullurl + (list (cons 'key (or *server-id* "thekey")) + (cons 'cmd cmd) + (cons 'params sparams)) + read-string)) transport: 'http) 0)) ;; added this speculatively ;; Shouldn't this be a call to the managed call-all-connections stuff above? (close-all-connections!) (mutex-unlock! *http-mutex*) @@ -265,17 +276,16 @@ (thread-start! th2) (thread-join! th1) (thread-terminate! th2) (debug:print-info 11 *default-log-port* "got res=" res) (if (vector? res) - (if (vector-ref res 0) - res + (if (vector-ref res 0) ;; this is the first flag or the second flag? + res ;; this is the *inner* vector? seriously? why? (if (debug:debug-mode 11) - (begin ;; note: this code also called in nmsg-transport - consider consolidating it - (debug:print-error 11 *default-log-port* "error occured at server, info=" (vector-ref res 2)) - (debug:print 11 *default-log-port* " client call chain:") + (let ((call-chain (get-call-chain))) ;; note: this code also called in nmsg-transport - consider consolidating it (print-call-chain (current-error-port)) + (debug:print-error 11 *default-log-port* "error above occured at server, res=" res " message: " ((condition-property-accessor 'exn 'message) exn)) (debug:print 11 *default-log-port* " server call chain:") (pp (vector-ref res 1) (current-error-port)) (signal (vector-ref res 0))) res)) (signal (make-composite-condition @@ -283,18 +293,25 @@ 'timeout 'message "nmsg-transport:client-api-send-receive-raw timed out talking to server"))))))) ;; careful closing of connections stored in *runremote* ;; -(define (http-transport:close-connections) - (let* ((server-dat (if *runremote* - (remote-conndat *runremote*) +(define (http-transport:close-connections #!key (area-dat #f)) + (let* ((runremote (or area-dat *runremote*)) + (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)) @@ -337,11 +354,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) @@ -366,22 +385,25 @@ (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 @@ -416,39 +438,39 @@ (if (common:low-noise-print 120 (conc "server running on " iface ":" port)) (begin (debug:print 0 *default-log-port* "SERVER STARTED: " iface ":" port " AT " (current-seconds)) (flush-output *default-log-port*))) - - (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)) + (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))) (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))) - (change-file-times server-log-file curr-time curr-time))) + (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?") + (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))))))) (define (http-transport:server-shutdown port) - (let ((tdbdat (tasks:open-db))) + (begin ;;(BB> "http-transport:server-shutdown called") (debug:print-info 0 *default-log-port* "Starting to shutdown the server. pid="(current-process-id)) ;; ;; start_shutdown ;; - ;; (tasks:server-set-state! (db:delay-if-busy tdbdat) server-id "shutting-down") (set! *time-to-exit* #t) ;; tell on-exit to be fast as we've already cleaned up (portlogger:open-run-close portlogger:set-port port "released") (thread-sleep! 1) ;; (debug:print-info 0 *default-log-port* "Max cached queries was " *max-cache-size*) @@ -475,52 +497,73 @@ ;; 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)))) + (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)))) ;;====================================================================== ;; web pages ;;====================================================================== @@ -540,22 +583,22 @@ (define (http-transport:stats-table) (mutex-lock! *heartbeat-mutex*) (let ((res (conc "

" - "" + ;; "" "" "" "" - "" "" "

Max cached queries	" max-cache-size "
Max cached queries	" max-cache-size "
Number of cached writes	" number-of-writes "
Average cached write time	" (if (eq? number-of-writes 0) "n/a (no writes)" (/ writes-total-delay number-of-writes)) " ms
Number non-cached queries	" number-non-write-queries "
Average non-cached time	" (if (eq? number-non-write-queries 0) - "n/a (no queries)" - (/ total-non-write-delay - number-non-write-queries)) + ;; "
Average non-cached time	" (if (eq? number-non-write-queries 0) + ;; "n/a (no queries)" + ;; (/ total-non-write-delay + ;; number-non-write-queries)) " ms
Last access	" (seconds->time-string db-last-access) "

"))) (mutex-unlock! *heartbeat-mutex*) res)) 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)) '(())))) 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 @@ -67,6 +67,13 @@ ;;====================================================================== (define (keys:config-get-fields confdat) (let ((fields (hash-table-ref/default confdat "fields" '()))) (map car 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 @@ -1,7 +1,7 @@ -;; Copyright 2006-2013, Matthew Welland. +;; 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 @@ -12,11 +12,11 @@ ;; launch a task - this runs on the originating host, tests themselves ;; ;;====================================================================== (use regex regex-case base64 sqlite3 srfi-18 directory-utils posix-extras z3 call-with-environment-variables csv) -(use typed-records pathname-expand) +(use typed-records pathname-expand matchable) (import (prefix base64 base64:)) (import (prefix sqlite3 sqlite3:)) (declare (unit launch)) @@ -61,21 +61,21 @@ ;; 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")) (msg (configf:lookup dat "final" "message"))) (if csvt ;; this if blocked stack dump caused by .dat file from logpro being 0-byte. fixed by upgrading logpro (rmt:csv->test-data run-id test-id csvt) (debug:print 0 *default-log-port* "ERROR: no csvdat exists for run-id: " run-id " test-id: " test-id " stepname: " stepname ", check that logpro version is 1.15 or newer")) - ;; (BB> "Error: run-id/test-id/stepname="run-id"/"test-id"/"stepname" => bad csvr="csvr) + ;; (debug:print-info 13 *default-log-port* "Error: run-id/test-id/stepname="run-id"/"test-id"/"stepname" => bad csvr="csvr) ;; ) (cond ((equal? status "PASS") "PASS") ;; skip the message part if status is pass (status (conc (configf:lookup dat "final" "exit-status") ": " (if msg msg "no message"))) (else #f))) @@ -90,11 +90,11 @@ (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))) (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 @@ -109,11 +109,11 @@ " stepparms: " stepparms " 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)) @@ -128,11 +128,11 @@ (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 +172,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)) @@ -296,11 +296,11 @@ ;; 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 (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)) @@ -308,20 +308,21 @@ ;; 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"))) + (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 4 *default-log-port* "WARNING: step " (car ezstep) " failed. Stopping"))) (debug:print 4 *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 +331,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,62 +406,156 @@ (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)) (tconfigreg #f)) (setenv "MT_CMDINFO" encoded-cmd) + ;;(bb-check-path msg: "launch:execute incoming") (if (list? cmdinfo) ;; ((testpath /tmp/mrwellan/jazzmind/src/example_run/tests/sqlitespeed) ;; (test-name sqlitespeed) (runscript runscript.rb) (db-host localhost) (run-id 1)) (let* ((testpath (assoc/default 'testpath cmdinfo)) ;; testpath is the test spec area (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)) ;; (runremote (assoc/default 'runremote cmdinfo)) - (transport (assoc/default 'transport cmdinfo)) + ;; (transport (assoc/default 'transport cmdinfo)) ;; not used ;; (serverinf (assoc/default 'serverinf cmdinfo)) - (port (assoc/default 'port cmdinfo)) + ;; (port (assoc/default 'port cmdinfo)) + (serverurl (assoc/default 'serverurl cmdinfo)) + (homehost (assoc/default 'homehost cmdinfo)) (run-id (assoc/default 'run-id cmdinfo)) (test-id (assoc/default 'test-id cmdinfo)) (target (assoc/default 'target cmdinfo)) + (areaname (assoc/default 'areaname cmdinfo)) (itemdat (assoc/default 'itemdat cmdinfo)) (env-ovrd (assoc/default 'env-ovrd cmdinfo)) (set-vars (assoc/default 'set-vars cmdinfo)) ;; pre-overrides from -setvar (runname (assoc/default 'runname cmdinfo)) (megatest (assoc/default 'megatest cmdinfo)) (runtlim (assoc/default 'runtlim cmdinfo)) + (contour (assoc/default 'contour cmdinfo)) (item-path (item-list->path itemdat)) (mt-bindir-path (assoc/default 'mt-bindir-path cmdinfo)) (keys #f) (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) + (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) + (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) + (if (or (common:directory-exists? work-area) (> count 10)) - (change-directory top-path) + (change-directory work-area) (begin - (debug:print 0 *default-log-port* "INFO: Not starting job yet - directory " top-path " not found") + (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) + (launch:setup) ;; should be properly in the top-path now (set! tconfigreg (tests:get-all)) (let ((sighand (lambda (signum) ;; (signal-mask! signum) ;; to mask or not? seems to cause issues in exiting (if (eq? signum signal/stop) @@ -477,14 +580,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")) @@ -503,11 +611,11 @@ (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))) @@ -515,11 +623,12 @@ ;; NOTE: Current order is to process runconfigs *before* setting the MT_ vars. This ;; seems non-ideal but could well break stuff ;; BUG? BUG? BUG? - (let ((rconfig (full-runconfigs-read))) ;; (read-config (conc *toppath* "/runconfigs.config") #f #t sections: (list "default" target)))) + (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) @@ -529,21 +638,22 @@ (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))))) - + ;;(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 (if (string? set-vars) @@ -555,10 +665,11 @@ (let ((var (car varval)) (val (cadr varval))) (debug:print 1 *default-log-port* "Adding pre-var/val " var " = " val " to the environment") (setenv var val))))) varpairs))) + ;;(bb-check-path msg: "launch:execute post block 2") (for-each (lambda (varval) (let ((var (car varval)) (val (cadr varval))) (if val @@ -572,24 +683,33 @@ (list "MT_ITEM_INFO" (conc itemdat)) (list "MT_ITEMPATH" item-path) (list "MT_RUNNAME" runname) (list "MT_MEGATEST" megatest) (list "MT_TARGET" target) - (list "MT_LINKTREE" (configf:lookup *configdat* "setup" "linktree")) - (list "MT_TESTSUITE_NAME" (common:get-testsuite-name)))) + (list "MT_LINKTREE" (common:get-linktree)) ;; (configf:lookup *configdat* "setup" "linktree")) + (list "MT_TESTSUITENAME" (common:get-testsuite-name)))) + ;;(bb-check-path msg: "launch:execute post block 3") (if mt-bindir-path (setenv "PATH" (conc (getenv "PATH") ":" mt-bindir-path))) + ;;(bb-check-path msg: "launch:execute post block 4") ;; (change-directory top-path) ;; Can setup as client for server mode now ;; (client:setup) ;; environment overrides are done *before* the remaining critical envars. (alist->env-vars env-ovrd) + ;;(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) - (save-environment-as-files "megatest") + ;;(bb-check-path msg: "launch:execute post block 43") + (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) @@ -596,11 +716,11 @@ ;; (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 @@ -669,42 +789,46 @@ (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") (args:get-arg "-runtests") (args:get-arg "-execute"))) - (let* ((linktree (get-environment-variable "MT_LINKTREE")) - (target (common:args-get-target)) + (let* ((linktree (common:get-linktree)) ;; (get-environment-variable "MT_LINKTREE")) + (target (common:args-get-target exit-if-bad: #t)) (runname (or (args:get-arg "-runname") (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) - (configf:write-alist *configdat* tmpfile) + (if (not (common:in-running-test?)) + (configf:write-alist *configdat* tmpfile)) (system (conc "ln -sf " tmpfile " " targfile)))) ))) (debug:print-info 1 *default-log-port* "No linktree yet, no caching configs."))))) @@ -721,159 +845,249 @@ ;; side effects: ;; sets; *configdat* (megatest.config info) ;; *runconfigdat* (runconfigs.config info) ;; *configstatus* (status of the read data) ;; -(define (launch:setup #!key (force #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))) + (let ((res (launch:setup-body force-reread: force-reread areapath: areapath))) (mutex-unlock! *launch-setup-mutex*) res))) -(define (launch:setup-body #!key (force #f)) - (let* ((toppath (or *toppath* (getenv "MT_RUN_AREA_HOME"))) ;; preserve toppath - (runname (common:args-get-runname)) - (target (common:args-get-target)) - (linktree (common:get-linktree)) - (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 "/" 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 (file-exists? rundir)(file-write-access? rundir))) - (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) - (set! *toppath* toppath) ;; This is needed when we are running as a test using CMDINFO as a datasource - (cond - ;; data was read and cached and available in *configstatus*, toppath has already been set - ((eq? *configstatus* 'fulldata) - *toppath*) - ;; if mtcachef exists just read it, however we need to assume toppath is available in $MT_RUN_AREA_HOME - ((and mtcachef (file-exists? mtcachef) (get-environment-variable "MT_RUN_AREA_HOME")) - (set! *configdat* (configf:read-alist mtcachef)) - (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*) - ;; we have all the info needed to fully process runconfigs and megatest.config - (mtcachef - (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")) - (first-rundat (let ((toppath (if toppath - toppath - (car first-pass)))) - (read-config ;; (conc toppath "/runconfigs.config") - (conc (if (string? toppath) - toppath - (get-environment-variable "MT_RUN_AREA_HOME")) - "/runconfigs.config") - *runconfigdat* #t - sections: sections)))) - (set! *runconfigdat* first-rundat) - (if first-pass ;; - (begin - (set! *configdat* (car first-pass)) - (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 - (debug:print-error 0 *default-log-port* "you are not in a megatest area!") - (exit 1))) - (setenv "MT_RUN_AREA_HOME" *toppath*) - ;; the seed read is done, now read runconfigs, cache it then read megatest.config one more time and cache it - (let* ((keys (rmt:get-keys)) - (key-vals (keys:target->keyval keys target)) - (linktree (or (getenv "MT_LINKTREE") - (if *configdat* (configf:lookup *configdat* "setup" "linktree") #f))) - (second-pass (find-and-read-config - mtconfig - environ-patt: "env-override" - given-toppath: toppath - pathenvvar: "MT_RUN_AREA_HOME")) - (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 - sections: sections)))) - (if cancreate (configf:write-alist runconfigdat rccachef)) - (set! *runconfigdat* runconfigdat) - (if cancreate (configf:write-alist *configdat* mtcachef)) - (if cancreate (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 - (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 - (let* ((toppath (or (get-environment-variable "MT_RUN_AREA_HOME")(cadr cfgdat))) - (rdat (read-config (conc toppath - "/runconfigs.config") *runconfigdat* #t sections: sections))) - (set! *configinfo* cfgdat) - (set! *configdat* (car cfgdat)) - (set! *runconfigdat* rdat) - (set! *toppath* toppath) - (set! *configstatus* 'partial)) - (begin - (debug:print-error 0 *default-log-port* "No " mtconfig " file found. Giving up.") - (exit 2)))))) - ;; additional house keeping - (let* ((linktree (or (getenv "MT_LINKTREE") - (if *configdat* (configf:lookup *configdat* "setup" "linktree") #f)))) - (if linktree - (begin - (if (not (file-exists? linktree)) - (begin - (handle-exceptions - exn - (begin - (debug:print-error 0 *default-log-port* "Something went wrong when trying to create linktree dir at " linktree) - (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) - (exit 1)) - (create-directory linktree #t)))) - (handle-exceptions - 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)) - (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* - (directory-exists? *toppath*)) - (begin - (setenv "MT_RUN_AREA_HOME" *toppath*) - (setenv "MT_TESTSUITE_NAME" (common:get-testsuite-name))) - (begin - (debug:print-error 0 *default-log-port* "failed to find the top path to your Megatest area.") - ;;(exit 1) - #f - )) - *toppath*)) +;; 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?)) ;; 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 + (target (common:args-get-target)) + (sections (if target (list "default" target) #f)) ;; for runconfigs + (mtconfig (or (args:get-arg "-config") "megatest.config")) ;; allow overriding megatest.config + (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 (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 + ((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")) + (first-rundat (let ((toppath (if toppath + toppath + (car first-pass)))) + (read-config ;; (conc toppath "/runconfigs.config") ;; this should be converted to runconfig:read but it is non-trivial, leaving it for now. + (conc (if (string? toppath) + toppath + (get-environment-variable "MT_RUN_AREA_HOME")) + "/runconfigs.config") + *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 + (debug:print-error 0 *default-log-port* "you are not in a megatest area!") + (exit 1))) + (setenv "MT_RUN_AREA_HOME" *toppath*) + ;; the seed read is done, now read runconfigs, cache it then read megatest.config one more time and cache it + (let* ((keys (rmt:get-keys)) + (key-vals (keys:target->keyval keys target)) + (linktree (common:get-linktree)) ;; (or (getenv "MT_LINKTREE")(if *configdat* (configf:lookup *configdat* "setup" "linktree") #f))) + ; (if *configdat* + ; (configf:lookup *configdat* "setup" "linktree") + ; (conc *toppath* "/lt")))) + (second-pass (find-and-read-config + mtconfig + environ-patt: "env-override" + given-toppath: toppath + pathenvvar: "MT_RUN_AREA_HOME")) + (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))) + (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 (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 (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)) + (set! *runconfigdat* rdat) + (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))) + (if linktree + (begin + (if (not (common:file-exists? linktree)) + (begin + (handle-exceptions + exn + (begin + (debug:print-error 0 *default-log-port* "Something went wrong when trying to create linktree dir at " linktree) + (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) + (exit 1)) + (create-directory linktree #t)))) + (handle-exceptions + 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 (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* + (directory-exists? *toppath*)) + (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.") + (set! *toppath* #f) ;; force it to be false so we return #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: "/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 (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. + *toppath*))) (define (get-best-disk confdat testconfig) (let* ((disks (or (and testconfig (hash-table-ref/default testconfig "disks" #f)) (hash-table-ref/default confdat "disks" #f))) (minspace (let ((m (configf:lookup confdat "setup" "minspace"))) @@ -884,10 +1098,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: ;; ;; - - -. ;; | @@ -907,10 +1137,11 @@ (runname (if (string? run-info) ;; if we pass in a string as run-info use it as run-name. run-info (db:get-value-by-header (db:get-rows run-info) (db:get-header run-info) "runname"))) + (contour #f) ;; NOT READY FOR THIS (args:get-arg "-contour")) ;; convert back to db: from rdb: - this is always run at server end (target (string-intersperse (map cadr keyvals) "/")) (not-iterated (equal? "" item-path)) @@ -917,34 +1148,36 @@ ;; all tests are found at /test-base or /test-base (testtop-base (conc target "/" runname "/" testname)) (test-base (conc testtop-base (if not-iterated "" "/") item-path)) ;; nb// if itempath is not "" then it is prefixed with "/" - (toptest-path (conc disk-path "/" testtop-base)) - (test-path (conc disk-path "/" test-base)) + (toptest-path (conc disk-path (if contour (conc "/" contour) "") "/" testtop-base)) + (test-path (conc disk-path (if contour (conc "/" contour) "") "/" test-base)) ;; ensure this exists first as links to subtests must be created there - (linktree (let ((rd (config-lookup *configdat* "setup" "linktree"))) - (if rd rd (conc *toppath* "/runs")))) + (linktree (common:get-linktree)) + ;; WAS: (let ((rd (config-lookup *configdat* "setup" "linktree"))) + ;; (if rd rd (conc *toppath* "/runs")))) + ;; which seems wrong ... - (lnkbase (conc linktree "/" target "/" runname)) + (lnkbase (conc linktree (if contour (conc "/" contour) "") "/" target "/" runname)) (lnkpath (conc lnkbase "/" testname)) (lnkpathf (conc lnkpath (if not-iterated "" "/") item-path)) (lnktarget (conc lnkpath "/" item-path))) ;; Update the rundir path in the test record for all, rundir=physical, shortdir=logical ;; rundir shortdir (rmt:general-call 'test-set-rundir-shortdir run-id lnkpathf test-path testname item-path run-id) (debug:print 2 *default-log-port* "INFO:\n lnkbase=" lnkbase "\n lnkpath=" lnkpath "\n toptest-path=" toptest-path "\n test-path=" test-path) - (if (not (file-exists? linktree)) + (if (not (common:file-exists? linktree)) (begin (debug:print 0 *default-log-port* "WARNING: linktree did not exist! Creating it now at " linktree) (create-directory linktree #t))) ;; (system (conc "mkdir -p " linktree)))) ;; create the directory for the tests dir links, this is needed no matter what... - (if (and (not (directory-exists? lnkbase)) - (not (file-exists? lnkbase))) + (if (and (not (common:directory-exists? lnkbase)) + (not (common:file-exists? lnkbase))) (handle-exceptions exn (begin (debug:print-error 0 *default-log-port* "Problem creating linktree base at " lnkbase) (print-error-message exn (current-error-port))) @@ -975,11 +1208,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") @@ -1000,11 +1233,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) @@ -1039,30 +1272,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) ;; @@ -1076,16 +1297,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 @@ -1092,10 +1328,11 @@ (list (list "MT_RUN_AREA_HOME" *toppath*) (list "MT_TEST_NAME" test-name) (list "MT_RUNNAME" runname) (list "MT_ITEMPATH" item-path) + (list "MT_CONTOUR" contour) ) itemdat)) (let* ((tregistry (tests:get-all)) ;; third param (below) is system-allowed ;; for tconfig, why do we allow fallback to test-conf? (tconfig (or (tests:get-testconfig test-name item-path tregistry #t force-create: #t) @@ -1172,12 +1409,20 @@ (set! cmdparms (base64:base64-encode (z3:encode-buffer (with-output-to-string (lambda () ;; (list 'hosts hosts) (write (list (list 'testpath test-path) - (list 'transport (conc *transport-type*)) + ;; (list 'transport (conc *transport-type*)) ;; (list 'serverinf *server-info*) + (list 'homehost (let* ((hhdat (common:get-homehost))) + (if hhdat + (car hhdat) + #f))) + (list 'serverurl (if *runremote* + (remote-server-url *runremote*) + #f)) ;; + (list 'areaname (common:get-testsuite-name)) (list 'toppath *toppath*) (list 'work-area work-area) (list 'test-name test-name) (list 'runscript runscript) (list 'run-id run-id ) @@ -1185,20 +1430,21 @@ ;; (list 'item-path item-path ) (list 'itemdat itemdat ) (list 'megatest remote-megatest) (list 'ezsteps ezsteps) (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))) (list 'runname runname) (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)))) @@ -1240,10 +1486,11 @@ (car fullcmd)) (if useshell '() (cdr fullcmd))))) (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 " ")) Index: lock-queue.scm ================================================================== --- lock-queue.scm +++ lock-queue.scm @@ -33,11 +33,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 +164,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: margs.scm ================================================================== --- margs.scm +++ margs.scm @@ -15,10 +15,14 @@ (define (args:get-arg arg . default) (if (null? default) (hash-table-ref/default args:arg-hash arg #f) (hash-table-ref/default args:arg-hash arg (car default)))) +(define (args:any? . args) + (not (null? (filter (lambda (x) x) + (map args:get-arg args))))) + (define (args:get-arg-from ht arg . default) (if (null? default) (hash-table-ref/default ht arg #f) (hash-table-ref/default ht arg (car default)))) @@ -27,10 +31,19 @@ (apply print "ERROR: " args)) (if (string? help) (print help) (print "Usage: " (car (argv)) " ... ")) (exit 0)) + + ;; one-of args defined +(define (args:any-defined? . param) + (let ((res #f)) + (for-each + (lambda (arg) + (if (args:get-arg arg)(set! res #t))) + param) + res)) ;; args: (define (args:get-args args params switches arg-hash num-needed) (let* ((numargs (length args)) (adj-num-needed (if num-needed (+ num-needed 2) #f))) 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.6306) +(define megatest-version 1.6429) ADDED megatest.config Index: megatest.config ================================================================== --- /dev/null +++ megatest.config @@ -0,0 +1,28 @@ + +## commented out due to a bug in v1.6501 in mtutil +## [fields] +## a text +## b text +## c text + +[setup] +pktsdirs /tmp/pkts /some/other/source + +[areas] +# path-to-area map-target-script(future, optional) +fullrun path=tests/fullrun +# targtrans is name of scheme proc stored in .mtutil.scm, which lives in PWD where mtutil is run +# ext-tests path=ext-tests; targtrans=prefix-contour; +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/ + +[nopurpose] + +[server] +timeout 1 Index: megatest.scm ================================================================== --- megatest.scm +++ megatest.scm @@ -1,6 +1,6 @@ -;; Copyright 2006-2012, Matthew Welland. +;; 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 @@ -53,32 +53,58 @@ (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 - -runall : run all tests or as specified by -testpatt + -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 @@ -86,21 +112,24 @@ -unlock : unlock run specified by target and runname -set-run-status status : sets status for run to status, requires -target and -runname -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 runconfig.config files + -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 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 runconfig + -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 -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 @@ -131,46 +160,51 @@ -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 -rebuild-db : bring the database schema up to date -cleanup-db : remove any orphan records, vacuum the db - -import-megatest.db : migrate a database from v1.55 series to v1.60 series - -sync-to-megatest.db : migrate data back to megatest.db - -use-db-cache : use cached access to db to reduce load + -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 -update-meta : update the tests metadata for all tests -setvars VAR1=val1,VAR2=val2 : Add environment variables to a run NB// these are overwritten by values set in config files. -server -|hostname : start the server (reduces contention on megatest.db), use - to automatically figure out hostname -transport http|rpc : use http or rpc for transport (default is http) - -daemonize : fork into background and disconnect from stdin/out -log logfile : send stdout and stderr to logfile -list-servers : list the servers - -stop-server id : stop server specified by id (see output of -list-servers), use - 0 to kill all + -kill-servers : kill all servers -repl : start a repl (useful for extending megatest) -load file.scm : load and run file.scm -mark-incompletes : find and mark incomplete tests -ping run-id|host:port : ping server, exit with 0 if found -debug N|N,M,O... : enable debug 0-N or N and M and O ... + -config fname : override the megatest.config file with fname + -append-config fname : append fname to the megatest.config file Utilities -env2file fname : write the environment to fname.csh and fname.sh - -envcap fname=context : save current variables labeled as context in file fname - -refdb2dat refdb : convert refdb to sexp or to format specified by -dumpmode + -envcap a : save current variables labeled as context 'a' in file envdat.db + -envdelta a-b : output enviroment delta from context a to context b to -o fname + set the output mode with -dumpmode csh, bash or ini + note: ini format will use calls to use curr and minimize path + -refdb2dat refdb : convert refdb to sexp or to format specified by s-dumpmode formats: perl, ruby, sqlite3, csv (for csv the -o param will substitute %s for the sheet name in generating multiple sheets) -o : output file for refdb2dat (defaults to stdout) -archive cmd : archive runs specified by selectors to one of disks specified @@ -203,17 +237,18 @@ Called as " (string-intersperse (argv) " ") " Version " megatest-version ", built from " megatest-fossil-hash )) ;; -gui : start a gui interface -;; -config fname : override the runconfig file with fname +;; -config fname : override the runconfigs file with fname ;; process args (define remargs (args:get-args (argv) (list "-runtests" ;; run a specific test "-config" ;; override the config file name + "-append-config" "-execute" ;; run the command encoded in the base64 parameter "-step" "-target" "-reqtarg" ":runname" @@ -221,10 +256,11 @@ ":state" "-state" ":status" "-status" "-list-runs" + "-testdata-csv" "-testpatt" "--modepatt" "-tagexpr" "-itempatt" "-setlog" @@ -243,14 +279,13 @@ ":expected" ":tol" ":units" ;; misc "-start-dir" + "-contour" "-server" - "-stop-server" "-transport" - "-kill-server" "-port" "-extract-ods" "-pathmod" "-env2file" "-envcap" @@ -276,14 +311,17 @@ "-fields" "-recover-test" ;; run-id,test-id - used internally to recover a test stuck in RUNNING state "-sort" "-target-db" "-source-db" + "-prefix-target" "-src-target" "-src-runname" "-diff-email" + "-sync-to" + "-pgsync" "-diff-html" ) (list "-h" "-help" "--help" "-manual" "-version" @@ -299,18 +337,22 @@ "-daemonize" "-preclean" "-rerun-clean" "-rerun-all" "-clean-cache" + "-no-cache" "-cache-db" "-use-db-cache" + "-prepend-contour" ;; misc "-repl" "-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" ;; misc queries "-list-disks" @@ -325,10 +367,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" @@ -337,11 +380,11 @@ "-convert-to-norm" "-convert-to-old" "-import-megatest.db" "-sync-to-megatest.db" "-sync-to-configdb" - + "-logging" "-v" ;; verbose 2, more than normal (normal is 1) "-q" ;; quiet 0, errors/warnings only "-diff-rep" @@ -357,22 +400,63 @@ (args:get-arg "-envcap") (args:get-arg "-envdelta") ) )) (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 (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.") + (exit 1)))) ;; immediately set MT_TARGET if -reqtarg or -target are available ;; (let ((targ (or (args:get-arg "-reqtarg")(args:get-arg "-target")))) (if targ (setenv "MT_TARGET" targ))) ;; The watchdog is to keep an eye on things like db sync etc. ;; -(define *watchdog* (make-thread 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 +;; TODO: for multiple areas, we will have multiple watchdogs; and multiple threads to manage +(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" + "-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 + (thread-start! *watchdog*))) + ;; bracket open-output-file with code to make leading directory if it does not exist and handle exceptions (define (open-logfile logpath) (condition-case (let* ((log-dir (or (pathname-directory logpath) "."))) @@ -382,20 +466,28 @@ (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 - (let* ((tl (or (args:get-arg "-log")(launch:setup))) ;; run launch:setup if -server - (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 - (debug:print-info 0 *default-log-port* "Sending log output to " logf) - (set! *default-log-port* oup))) + (handle-exceptions + exn + (begin + (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, 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 + (debug:print-info 0 *default-log-port* "Sending log output to " logf) + (set! *default-log-port* oup)))) (if (or (args:get-arg "-h") (args:get-arg "-help") (args:get-arg "--help")) (begin @@ -406,22 +498,15 @@ (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 "-start-dir") - (if (file-exists? (args:get-arg "-start-dir")) - (change-directory (args:get-arg "-start-dir")) - (begin - (debug:print-error 0 *default-log-port* "non-existant start dir " (args:get-arg "-start-dir") " specified, exiting.") - (exit 1)))) - (if (args:get-arg "-version") (begin (print (common:version-signature)) ;; (print megatest-version) (exit))) @@ -435,11 +520,12 @@ ;; (args:get-arg "-remove-runs") ;; (args:get-arg "-runstep")) (let ((original-exit (exit-handler))) (exit-handler (lambda (#!optional (exit-code 0)) (printf "Preparing to exit with exit code ~A ...\n" exit-code) - (for-each + (for-each + (lambda (pid) (handle-exceptions exn #t (let-values (((pid-val exit-status exit-code) (process-wait pid #t))) @@ -448,10 +534,29 @@ (begin (printf "Sending signal/term to ~A\n" pid) (process-signal pid signal/term)))))) (process:children #f)) (original-exit exit-code))))) + +;; 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 ;;====================================================================== @@ -486,35 +591,17 @@ (set! *didsomething* #t))) ;; handle a clean-cache request as early as possible ;; (if (args:get-arg "-clean-cache") - (begin + (let ((toppath (launch:setup))) (set! *didsomething* #t) ;; suppress the help output. - (if (getenv "MT_TARGET") ;; no point in trying if no target - (if (args:get-arg "-runname") - (let* ((toppath (launch:setup)) - (linktree (if toppath (configf:lookup *configdat* "setup" "linktree"))) - (runtop (conc linktree "/" (getenv "MT_TARGET") "/" (args:get-arg "-runname"))) - (files (if (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.") - (begin - (debug:print-info 0 *default-log-port* "Removing cached files:\n " (string-intersperse files "\n ")) - (for-each - (lambda (f) - (handle-exceptions - exn - (debug:print 0 *default-log-port* "WARNING: Failed to remove file " f) - (delete-file f))) - files)))) - (debug:print-error 0 *default-log-port* "-clean-cache requires -runname.")) - (debug:print-error 0 *default-log-port* "-clean-cache requires -target or -reqtarg")))) - + (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))) @@ -666,11 +753,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) @@ -742,69 +829,55 @@ (transport-type (string->symbol (or (args:get-arg "-transport") "http")))) (server:launch 0 transport-type) (set! *didsomething* #t))) (if (or (args:get-arg "-list-servers") - (args:get-arg "-stop-server") - (args:get-arg "-kill-server")) + (args:get-arg "-kill-servers")) (let ((tl (launch:setup))) - (if tl - (let* ((tdbdat (tasks:open-db)) - (servers (tasks:get-all-servers (db:delay-if-busy tdbdat))) - (fmtstr "~5a~12a~8a~20a~24a~10a~10a~10a~10a\n") - (servers-to-kill '()) - (kill-switch (if (args:get-arg "-kill-server") "-9" "")) - (killinfo (or (args:get-arg "-stop-server") (args:get-arg "-kill-server") )) - (khost-port (if killinfo (if (substring-index ":" killinfo)(string-split ":") #f) #f)) - (sid (if killinfo (if (substring-index ":" killinfo) #f (string->number killinfo)) #f))) - (format #t fmtstr "Id" "MTver" "Pid" "Host" "Interface:OutPort" "InPort" "LastBeat" "State" "Transport") - (format #t fmtstr "==" "=====" "===" "====" "=================" "======" "========" "=====" "=========") - (for-each + (if tl ;; all roads from here exit + (let* ((servers (server:get-list *toppath*)) + (fmtstr "~8a~22a~20a~20a~8a\n")) + (format #t fmtstr "pid" "Interface:port" "age (hms)" "Last mod" "State") + (format #t fmtstr "===" "==============" "=========" "========" "=====") + (for-each ;; ( mod-time host port start-time pid ) (lambda (server) - (let* ((id (vector-ref server 0)) - (pid (vector-ref server 1)) - (hostname (vector-ref server 2)) - (interface (vector-ref server 3)) - (pullport (vector-ref server 4)) - (pubport (vector-ref server 5)) - (start-time (vector-ref server 6)) - (priority (vector-ref server 7)) - (state (vector-ref server 8)) - (mt-ver (vector-ref server 9)) - (last-update (vector-ref server 10)) - (transport (vector-ref server 11)) - (killed #f) - (status (< last-update 20))) - ;; (zmq-sockets (if status (server:client-connect hostname port) #f))) - ;; no need to login as status of #t indicates we are connecting to correct - ;; server - (if (equal? state "dead") - (if (> last-update (* 25 60 60)) ;; keep records around for slighly over a day. - (tasks:server-deregister (db:delay-if-busy tdbdat) hostname pullport: pullport pid: pid action: 'delete)) - (if (> last-update 20) ;; Mark as dead if not updated in last 20 seconds - (tasks:server-deregister (db:delay-if-busy tdbdat) hostname pullport: pullport pid: pid))) - (format #t fmtstr id mt-ver pid hostname (conc interface ":" pullport) pubport last-update - (if status "alive" "dead") transport) - (if (or (equal? id sid) - (equal? sid 0)) ;; kill all/any + (let* ((mtm (any->number (car server))) + (mod (if mtm (- (current-seconds) mtm) "unk")) + (age (- (current-seconds)(or (any->number (list-ref server 3)) (current-seconds)))) + (url (conc (cadr server) ":" (caddr server))) + (pid (list-ref server 4)) + (alv (if (number? mod)(< mod 10) #f))) + (format #t + fmtstr + pid + url + (seconds->hr-min-sec age) + (seconds->hr-min-sec mod) + (if alv "alive" "dead")) + (if (and alv + (args:get-arg "-kill-servers")) (begin - (debug:print-info 0 *default-log-port* "Attempting to kill "kill-switch" server with pid " pid) - (tasks:kill-server hostname pid kill-switch: kill-switch))))) - servers) - (debug:print-info 1 *default-log-port* "Done with listservers") + (debug:print-info 0 *default-log-port* "Attempting to kill server with pid " pid) + (server:kill server))))) + (sort servers (lambda (a b) + (let ((ma (or (any->number (car a)) 9e9)) + (mb (or (any->number (car b)) 9e9))) + (> ma mb))))) + ;; (debug:print-info 1 *default-log-port* "Done with listservers") (set! *didsomething* #t) - (exit)) ;; must do, would have to add checks to many/all calls below + (exit)) (exit)))) + ;; must do, would have to add checks to many/all calls below ;;====================================================================== ;; Weird special calls that need to run *after* the server has started? ;;====================================================================== (if (args:get-arg "-list-targets") (if (launch:setup) (let ((targets (common:get-runconfig-targets))) - (debug:print 1 *default-log-port* "Found "(length targets) " targets") + ;; (debug:print 1 *default-log-port* "Found "(length targets) " targets") (case (string->symbol (or (args:get-arg "-dumpmode") "alist")) ((alist) (for-each (lambda (x) ;; (print "[" x "]")) (print x)) @@ -828,12 +901,13 @@ (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) - (file-write-access? 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)) (key-vals (if target (keys:target->keyval keys target) #f)) (sections (if target (list "default" target) #f)) @@ -841,19 +915,22 @@ (setenv "MT_RUN_AREA_HOME" *toppath*) (if key-vals (for-each (lambda (kt) (setenv (car kt) (cadr kt))) key-vals)) - (read-config (conc *toppath* "/runconfigs.config") #f #t sections: sections)))) + ;; (read-config (conc *toppath* "/runconfigs.config") #f #t sections: sections)))) + (runconfig:read (conc *toppath* "/runconfigs.config") target #f)))) (if (and rundir ;; have all needed variabless (directory-exists? rundir) (file-write-access? rundir)) (begin - (configf:write-alist data cfgf) + (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*) @@ -863,16 +940,17 @@ ((and (args:get-arg "-section") (args:get-arg "-var")) (let ((val (or (configf:lookup data (args:get-arg "-section")(args:get-arg "-var")) (configf:lookup data "default" (args:get-arg "-var"))))) (if val (print val)))) - ((not (args:get-arg "-dumpmode")) + ((or (not (args:get-arg "-dumpmode")) + (string=? (args:get-arg "-dumpmode") "ini")) + (configf:config->ini data)) + ((string=? (args:get-arg "-dumpmode") "sexp") (pp (hash-table->alist data))) ((string=? (args:get-arg "-dumpmode") "json") (json-write data)) - ((string=? (args:get-arg "-dumpmode") "ini") - (configf:config->ini data)) (else (debug:print-error 0 *default-log-port* "-dumpmode of " (args:get-arg "-dumpmode") " not recognised"))) (set! *didsomething* #t)) (pop-directory))) @@ -896,11 +974,12 @@ ((string=? (args:get-arg "-dumpmode") "ini") (configf:config->ini data)) (else (debug:print-error 0 *default-log-port* "-dumpmode of " (args:get-arg "-dumpmode") " not recognised"))) (set! *didsomething* #t) - (pop-directory))) + (pop-directory) + (set! *time-to-exit* #t))) (if (args:get-arg "-show-cmdinfo") (if (or (args:get-arg ":value")(getenv "MT_CMDINFO")) (let ((data (common:read-encoded-string (or (args:get-arg ":value")(getenv "MT_CMDINFO"))))) (if (equal? (args:get-arg "-dumpmode") "json") @@ -913,11 +992,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") @@ -942,19 +1021,22 @@ 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 "-set-state-status") (general-run-call "-set-state-status" "set state and status" @@ -1008,10 +1090,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% ... ;; @@ -1049,11 +1235,11 @@ ;; (reverse new-res) ;; (loop (car tal)(cdr tal) new-res))))) ;; runstmp)) (db-targets (args:get-arg "-list-db-targets")) (seen (make-hash-table)) - (dmode (let ((d (args:get-arg "-dumpmode"))) + (dmode (let ((d (args:get-arg "-dumpmode"))) ;; json, sexpr (if d (string->symbol d) #f))) (data (make-hash-table)) (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"))) @@ -1078,11 +1264,10 @@ (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))))) - ;; Each run (for-each (lambda (run) (let ((targetstr (string-intersperse (map (lambda (x) (db:get-value-by-header run header x)) @@ -1109,11 +1294,11 @@ #f) #f 'normal) '()))) (case dmode - ((json ods) + ((json ods sexpr) (if runs-spec (for-each (lambda (field-name) (mutils:hierhash-set! data (conc (db:get-value-by-header run header field-name)) targetstr runname "meta" field-name)) runs-spec))) @@ -1142,15 +1327,15 @@ runs-spec) (newline))))) (for-each (lambda (test) - (handle-exceptions + (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)) @@ -1164,11 +1349,11 @@ (fullname (conc testname (if (equal? itempath "") "" (conc "(" itempath ")"))))) (case dmode - ((json ods) + ((json ods sexpr) (if tests-spec (for-each (lambda (field-name) (mutils:hierhash-set! data (get-value-by-fieldname test test-field-index field-name) targetstr runname "data" (conc test-id) field-name)) tests-spec))) @@ -1247,11 +1432,13 @@ ((and (string? first)(string? second)) string<=?) (else equal?)) first second)))) tests)))))) runs) - (if (eq? dmode 'json)(json-write data)) + (case dmode + ((json) (json-write data)) + ((sexpr) (pp (common:to-alist data)))) (let* ((metadat-fields (delete-duplicates (append keys '( "runname" "time" "owner" "pass_count" "fail_count" "state" "status" "comment" "id")))) (run-fields '( "testname" "item_path" @@ -1320,11 +1507,11 @@ (cons (conc target "/" runname) (cons (list (conc target "/" runname)) (cons '() (cons run-fields tests))))) (begin - (debug:print 0 *default-log-port* "WARNING: run " target "/" runname " appears to have no data") + (debug:print 4 *default-log-port* "WARNING: run " target "/" runname " appears to have no data") ;; (pp rundat) '())))) runsdat) '()))) newdat)) ;; we use newdat to get target @@ -1346,11 +1533,15 @@ (debug:print 0 *default-log-port* "WARNING: path given, " outputfile " is relative, prefixing with current directory") (conc (current-directory) "/" outputfile))))) (create-directory tempdir #t) (ods:list->ods tempdir ouf sheets)))) ;; (system (conc "rm -rf " tempdir)) - (set! *didsomething* #t)))) + (set! *didsomething* #t) + (set! *time-to-exit* #t) + ) ;; end if true branch (end of a let) + ) ;; end if + ) ;; end if -list-runs ;; Don't think I need this. Incorporated into -list-runs instead ;; ;; (if (and (args:get-arg "-since") ;; (launch:setup)) @@ -1383,59 +1574,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: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: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"))) + (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 ;;====================================================================== @@ -1537,11 +1732,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" @@ -1827,20 +2022,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 @@ -1895,11 +2092,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 @@ -1984,34 +2181,33 @@ ;; ;; ;; 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-configdb") - (begin +(if (args:get-arg "-sync-to") + (let ((toppath (launch:setup))) + (tasks:sync-to-postgres *configdat* (args:get-arg "-sync-to")) (db:multi-db-sync (db:setup) 'synctoconfig - ) - (set! *didsomething* #t))) + (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") @@ -2021,15 +2217,18 @@ ;;====================================================================== ;; Exit and clean up ;;====================================================================== (if (not *didsomething*) - (debug:print 0 *default-log-port* help)) -;;(BB> "thread-join! watchdog") + (debug:print 0 *default-log-port* help) + (set! *time-to-exit* #t) + ) +;;(debug:print-info 13 *default-log-port* "thread-join! watchdog") ;; join the watchdog thread if it has been thread-start!ed (it may not have been started in the case of a server that never enters running state) ;; (symbols returned by thread-state: created ready running blocked suspended sleeping terminated dead) +;; TODO: for multiple areas, we will have multiple watchdogs; and multiple threads to manage (if (thread? *watchdog*) (case (thread-state *watchdog*) ((ready running blocked sleeping terminated dead) (thread-join! *watchdog*)))) ADDED mt-pg.sql Index: mt-pg.sql ================================================================== --- /dev/null +++ mt-pg.sql @@ -0,0 +1,216 @@ +-- CREATE TABLE IF NOT EXISTS keys ( +-- id SERIAL PRIMARY KEY, +-- fieldname TEXT, +-- fieldtype TEXT, +-- CONSTRAINT keyconstraint UNIQUE (fieldname)); + +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; +DROP TABLE IF EXISTS tasks_queue; +DROP TABLE IF EXISTS archive_disks; +DROP TABLE IF EXISTS archive_blocks; +DROP TABLE IF EXISTS archive_allocations; +DROP TABLE IF EXISTS extradat; +DROP TABLE IF EXISTS metadat; +DROP TABLE IF EXISTS access_log; +DROP TABLE IF EXISTS tests; +DROP TABLE IF EXISTS test_steps; +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; + +CREATE TABLE IF NOT EXISTS session_vars ( + id SERIAL PRIMARY KEY, + session_id INTEGER, + page TEXT, + key TEXT, + value TEXT); + +CREATE TABLE IF NOT EXISTS sessions ( + id SERIAL PRIMARY KEY, + session_key TEXT NOT NULL, + last_used TIMESTAMP WITHOUT TIME ZONE DEFAULT now()); + +CREATE TABLE IF NOT EXISTS areas ( + id SERIAL PRIMARY KEY, + area_name TEXT NOT NULL, + area_path TEXT NOT NULL, + last_sync INTEGER DEFAULT 0, + CONSTRAINT areaconstraint UNIQUE (area_name)); + +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 ''); + +CREATE TABLE IF NOT EXISTS runs ( + id SERIAL PRIMARY KEY, + target TEXT DEFAULT '', + ttype_id INTEGER DEFAULT 0, + run_name TEXT DEFAULT 'norun', + state TEXT DEFAULT '', + status TEXT DEFAULT '', + owner TEXT DEFAULT '', + event_time INTEGER DEFAULT extract(epoch from now()), + 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)); + +CREATE TABLE IF NOT EXISTS run_stats ( + id SERIAL PRIMARY KEY, + run_id INTEGER, + state TEXT, + status TEXT, + count INTEGER, + last_update INTEGER DEFAULT extract(epoch from now())); + +CREATE TABLE IF NOT EXISTS test_meta ( + id SERIAL PRIMARY KEY, + test_name TEXT DEFAULT '', + author TEXT DEFAULT '', + owner TEXT DEFAULT '', + description TEXT DEFAULT '', + reviewed TEXT, + iterated TEXT DEFAULT '', + avg_runtime REAL, + avg_disk REAL, + tags TEXT DEFAULT '', + jobgroup TEXT DEFAULT 'default', + CONSTRAINT test_meta_constraint UNIQUE (test_name)); + +CREATE TABLE IF NOT EXISTS tasks_queue ( + id SERIAL PRIMARY KEY, + action TEXT DEFAULT '', + owner TEXT, + state TEXT DEFAULT 'new', + target TEXT DEFAULT '', + name TEXT DEFAULT '', + testpatt TEXT DEFAULT '', + keylock TEXT, + params TEXT, + creation_time INTEGER DEFAULT extract(epoch from now()), + execution_time INTEGER); + +CREATE TABLE IF NOT EXISTS archive_disks ( + id SERIAL PRIMARY KEY, + archive_area_name TEXT, + disk_path TEXT, + last_df INTEGER DEFAULT -1, + last_df_time INTEGER DEFAULT extract(epoch from now()), + creation_time INTEGER DEFAULT extract(epoch from now())); + +CREATE TABLE IF NOT EXISTS archive_blocks ( + id SERIAL PRIMARY KEY, + archive_disk_id INTEGER, + disk_path TEXT, + last_du INTEGER DEFAULT -1, + last_du_time INTEGER DEFAULT extract(epoch from now()), + creation_time INTEGER DEFAULT extract(epoch from now())); + +CREATE TABLE IF NOT EXISTS archive_allocations ( + id SERIAL PRIMARY KEY, + archive_block_id INTEGER, + test_name TEXT, + item_path TEXT, + creation_time INTEGER DEFAULT extract(epoch from now())); + +CREATE TABLE IF NOT EXISTS extradat ( + id SERIAL PRIMARY KEY, + run_id INTEGER, + key TEXT, + val TEXT); + +CREATE TABLE IF NOT EXISTS metadat ( + id SERIAL PRIMARY KEY, + var TEXT, + val TEXT); + +CREATE TABLE IF NOT EXISTS access_log ( + id SERIAL PRIMARY KEY, + "user" TEXT, + accessed TIMESTAMP, + args TEXT); + +CREATE TABLE IF NOT EXISTS tests ( + id SERIAL PRIMARY KEY, + run_id INTEGER DEFAULT -1, + test_name TEXT DEFAULT 'noname', + item_path TEXT DEFAULT '', + state TEXT DEFAULT 'NOT_STARTED', + status TEXT DEFAULT 'FAIL', + host TEXT DEFAULT 'n/a', + cpuload REAL DEFAULT -1, + diskfree INTEGER DEFAULT -1, + uname TEXT DEFAULT 'n/a', + rundir TEXT DEFAULT '/tmp/badname', + shortdir TEXT DEFAULT '/tmp/badname', + attemptnum INTEGER DEFAULT 0, + final_logf TEXT DEFAULT 'logs/final.log', + logdat TEXT DEFAULT '', + run_duration INTEGER DEFAULT 0, + comment TEXT DEFAULT '', + event_time INTEGER DEFAULT extract(epoch from now()), + 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 extract(epoch from now()), + CONSTRAINT testsconstraint UNIQUE (run_id, test_name, item_path)); + +CREATE TABLE IF NOT EXISTS test_steps ( + id SERIAL PRIMARY KEY, + test_id INTEGER, + stepname TEXT, + state TEXT DEFAULT 'NOT_STARTED', + status TEXT DEFAULT 'n/a', + event_time INTEGER DEFAULT extract(epoch from now()), + comment TEXT DEFAULT '', + logfile TEXT DEFAULT '', + last_update INTEGER DEFAULT extract(epoch from now()), + CONSTRAINT test_steps_constraint UNIQUE (test_id,stepname,state)); + +CREATE TABLE IF NOT EXISTS test_data ( + id SERIAL PRIMARY KEY, + test_id INTEGER, + category TEXT DEFAULT '', + variable TEXT, + value REAL, + expected REAL, + tol REAL, + units TEXT, + comment TEXT DEFAULT '', + status TEXT DEFAULT 'n/a', + type TEXT DEFAULT '', + last_update INTEGER DEFAULT extract(epoch from now()), + CONSTRAINT test_data_constraint UNIQUE (test_id,category,variable)); + +CREATE TABLE IF NOT EXISTS test_rundat ( + id SERIAL PRIMARY KEY, + test_id INTEGER, + update_time INTEGER, + cpuload INTEGER DEFAULT -1, + diskfree INTEGER DEFAULT -1, + diskusage INTEGER DEFAULT -1, + run_duration INTEGER DEFAULT 0); + +CREATE TABLE IF NOT EXISTS archives ( + id SERIAL PRIMARY KEY, + test_id INTEGER, + state TEXT DEFAULT 'new', + status TEXT DEFAULT 'n/a', + archive_type TEXT DEFAULT 'bup', + du INTEGER, + archive_path 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; ADDED mt-sqlite3.sql Index: mt-sqlite3.sql ================================================================== --- /dev/null +++ mt-sqlite3.sql @@ -0,0 +1,216 @@ +-- CREATE TABLE IF NOT EXISTS keys ( +-- id SERIAL PRIMARY KEY, +-- fieldname TEXT, +-- fieldtype TEXT, +-- CONSTRAINT keyconstraint UNIQUE (fieldname)); + +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; +DROP TABLE IF EXISTS tasks_queue; +DROP TABLE IF EXISTS archive_disks; +DROP TABLE IF EXISTS archive_blocks; +DROP TABLE IF EXISTS archive_allocations; +DROP TABLE IF EXISTS extradat; +DROP TABLE IF EXISTS metadat; +DROP TABLE IF EXISTS access_log; +DROP TABLE IF EXISTS tests; +DROP TABLE IF EXISTS test_steps; +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; + +CREATE TABLE IF NOT EXISTS session_vars ( + id SERIAL PRIMARY KEY, + session_id INTEGER, + page TEXT, + key TEXT, + value TEXT); + +CREATE TABLE IF NOT EXISTS sessions ( + id SERIAL PRIMARY KEY, + session_key TEXT NOT NULL, + last_used TIMESTAMP WITHOUT TIME ZONE DEFAULT (strftime('%s','now'))); + +CREATE TABLE IF NOT EXISTS areas ( + id SERIAL PRIMARY KEY, + area_name TEXT NOT NULL, + area_path TEXT NOT NULL, + last_sync INTEGER DEFAULT 0, + CONSTRAINT areaconstraint UNIQUE (area_name)); + +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 ''); + +CREATE TABLE IF NOT EXISTS runs ( + id SERIAL PRIMARY KEY, + target TEXT DEFAULT '', + ttype_id INTEGER DEFAULT 0, + run_name TEXT DEFAULT 'norun', + state TEXT DEFAULT '', + status TEXT DEFAULT '', + owner TEXT DEFAULT '', + event_time INTEGER DEFAULT (strftime('%s','now')), + comment TEXT DEFAULT '', + fail_count INTEGER DEFAULT 0, + pass_count INTEGER DEFAULT 0, + last_update INTEGER DEFAULT (strftime('%s','now')), + area_id INTEGER DEFAULT 0, + CONSTRAINT runsconstraint UNIQUE (target,ttype_id,run_name)); + +CREATE TABLE IF NOT EXISTS run_stats ( + id SERIAL PRIMARY KEY, + run_id INTEGER, + state TEXT, + status TEXT, + count INTEGER, + last_update INTEGER DEFAULT (strftime('%s','now'))); + +CREATE TABLE IF NOT EXISTS test_meta ( + id SERIAL PRIMARY KEY, + test_name TEXT DEFAULT '', + author TEXT DEFAULT '', + owner TEXT DEFAULT '', + description TEXT DEFAULT '', + reviewed TEXT, + iterated TEXT DEFAULT '', + avg_runtime REAL, + avg_disk REAL, + tags TEXT DEFAULT '', + jobgroup TEXT DEFAULT 'default', + CONSTRAINT test_meta_constraint UNIQUE (test_name)); + +CREATE TABLE IF NOT EXISTS tasks_queue ( + id SERIAL PRIMARY KEY, + action TEXT DEFAULT '', + owner TEXT, + state TEXT DEFAULT 'new', + target TEXT DEFAULT '', + name TEXT DEFAULT '', + testpatt TEXT DEFAULT '', + keylock TEXT, + params TEXT, + creation_time INTEGER DEFAULT (strftime('%s','now')), + execution_time INTEGER); + +CREATE TABLE IF NOT EXISTS archive_disks ( + id SERIAL PRIMARY KEY, + archive_area_name TEXT, + disk_path TEXT, + last_df INTEGER DEFAULT -1, + last_df_time INTEGER DEFAULT (strftime('%s','now')), + creation_time INTEGER DEFAULT (strftime('%s','now'))); + +CREATE TABLE IF NOT EXISTS archive_blocks ( + id SERIAL PRIMARY KEY, + archive_disk_id INTEGER, + disk_path TEXT, + last_du INTEGER DEFAULT -1, + last_du_time INTEGER DEFAULT (strftime('%s','now')), + creation_time INTEGER DEFAULT (strftime('%s','now'))); + +CREATE TABLE IF NOT EXISTS archive_allocations ( + id SERIAL PRIMARY KEY, + archive_block_id INTEGER, + test_name TEXT, + item_path TEXT, + creation_time INTEGER DEFAULT (strftime('%s','now'))); + +CREATE TABLE IF NOT EXISTS extradat ( + id SERIAL PRIMARY KEY, + run_id INTEGER, + key TEXT, + val TEXT); + +CREATE TABLE IF NOT EXISTS metadat ( + id SERIAL PRIMARY KEY, + var TEXT, + val TEXT); + +CREATE TABLE IF NOT EXISTS access_log ( + id SERIAL PRIMARY KEY, + "user" TEXT, + accessed TIMESTAMP, + args TEXT); + +CREATE TABLE IF NOT EXISTS tests ( + id SERIAL PRIMARY KEY, + run_id INTEGER DEFAULT -1, + test_name TEXT DEFAULT 'noname', + item_path TEXT DEFAULT '', + state TEXT DEFAULT 'NOT_STARTED', + status TEXT DEFAULT 'FAIL', + host TEXT DEFAULT 'n/a', + cpuload REAL DEFAULT -1, + diskfree INTEGER DEFAULT -1, + uname TEXT DEFAULT 'n/a', + rundir TEXT DEFAULT '/tmp/badname', + shortdir TEXT DEFAULT '/tmp/badname', + attemptnum INTEGER DEFAULT 0, + final_logf TEXT DEFAULT 'logs/final.log', + logdat TEXT DEFAULT '', + run_duration INTEGER DEFAULT 0, + comment TEXT DEFAULT '', + event_time INTEGER DEFAULT (strftime('%s','now')), + 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, test_name, item_path)); + +CREATE TABLE IF NOT EXISTS test_steps ( + id SERIAL PRIMARY KEY, + test_id INTEGER, + stepname TEXT, + state TEXT DEFAULT 'NOT_STARTED', + status TEXT DEFAULT 'n/a', + event_time INTEGER DEFAULT (strftime('%s','now')), + comment TEXT DEFAULT '', + logfile TEXT DEFAULT '', + last_update INTEGER DEFAULT (strftime('%s','now')), + CONSTRAINT test_steps_constraint UNIQUE (test_id,stepname,state)); + +CREATE TABLE IF NOT EXISTS test_data ( + id SERIAL PRIMARY KEY, + test_id INTEGER, + category TEXT DEFAULT '', + variable TEXT, + value REAL, + expected REAL, + tol REAL, + units TEXT, + 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)); + +CREATE TABLE IF NOT EXISTS test_rundat ( + id SERIAL PRIMARY KEY, + test_id INTEGER, + update_time INTEGER, + cpuload INTEGER DEFAULT -1, + diskfree INTEGER DEFAULT -1, + diskusage INTEGER DEFAULT -1, + run_duration INTEGER DEFAULT 0); + +CREATE TABLE IF NOT EXISTS archives ( + id SERIAL PRIMARY KEY, + test_id INTEGER, + state TEXT DEFAULT 'new', + status TEXT DEFAULT 'n/a', + archive_type TEXT DEFAULT 'bup', + du INTEGER, + archive_path 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 @@ -127,47 +127,90 @@ (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*) + (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,13 +249,13 @@ (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 (configf:lookup *configdat* "setup" "linktree")) + (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 ...] (hash-table-set! *testconfigs* test-name newtcfg) (if old-link-tree ADDED mtut.scm Index: mtut.scm ================================================================== --- /dev/null +++ mtut.scm @@ -0,0 +1,1015 @@ +;; 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. + +;; (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:) + (prefix nanomsg nmsg:)) + +(declare (uses common)) +(declare (uses megatest-version)) +(declare (uses margs)) +(declare (uses configf)) +;; (declare (uses rmt)) + +(include "megatest-fossil-hash.scm") + +(require-library stml) + +(define *target-mappers* (make-hash-table)) ;; '()) +(define *runname-mappers* (make-hash-table)) ;; '()) + +;; 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 (common:file-exists? "megatest.config") + (if (common:file-exists? ".mtutil.so") + (load ".mtutil.so") + (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 +;; import : import pkts +;; dispatch : dispatch queued run jobs from imported pkts +;; rungen : look at input sense list in [rungen] and generate run pkts + +(define help (conc " +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 + +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\" + +Examples: + +# Start a megatest run in the area \"mytests\" +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) " ") " +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 + ("-target" . t) + ("-run-name" . n) + ("-state" . e) + ("-status" . s) + ("-contour" . c) + ("-test-patt" . p) ;; idea, enhance margs ("-test-patt" "-testpatt") => yields one value in "-test-patt" + ("-mode-patt" . o) + ("-tag-expr" . x) + ("-item-patt" . i) + ("-sync-to" . k) + ("-append-config" . d) + ;; misc + ("-start-dir" . S) + ("-msg" . M) + ("-set-vars" . v) + ("-debug" . #f) ;; for *verbosity* > 2 + ("-load" . #f) ;; load and exectute a scheme file + ("-log" . #f) + )) +(define *switch-keys* + '(("-h" . #f) + ("-help" . #f) + ("--help" . #f) + ("-manual" . #f) + ("-version" . #f) + ;; misc + ("-repl" . #f) + ("-immediate" . I) + ("-preclean" . r) + ("-rerun-all" . u) + )) + +;; alist to map actions to old megatest commands +(define *action-keys* + '((run . "-run") + (sync . "") + (archive . "-archive") + (set-ss . "-set-state-status") + (remove . "-remove-runs"))) + +;; inlst is an alternative input +;; +(define (lookup-param-by-key key #!key (inlst #f)) + (fold (lambda (a res) + (if (eq? (cdr a) key) + (car a) + res)) + #f + (or inlst *arg-keys*))) + +(define (lookup-action-by-key key) + (alist-ref (string->symbol key) *action-keys*)) + +;;====================================================================== +;; 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 (push-run-spec torun contour runkey spec) + (configf:section-var-set! torun contour runkey + (cons spec + (or (configf:lookup torun contour runkey) + '())))) + +(define (fossil:clone-or-sync url name dest-dir) + (let ((targ-file (conc dest-dir "/" name))) ;; do not force usage of .fossil extension + (handle-exceptions + exn + (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 (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) + (let* ((fossil-file (conc fossils-dir "/" fossil-name)) + (timeline-port (if (file-read-access? fossil-file) + (handle-exceptions + exn + (begin + (print "ERROR: failed to get timeline from " fossil-file " message: " ((condition-property-accessor 'exn 'message) exn)) + #f) + (open-input-pipe (conc "fossil timeline -t ci -W 0 -n 0 -R " fossil-file))) + #f)) + (get-line (lambda () + (handle-exceptions + exn + (begin + (print "ERROR: failed to read from file " fossil-file " message: " ((condition-property-accessor 'exn 'message) exn)) + #f) + (read-line timeline-port)))) + (date-rx (regexp "^=== (\\S+) ===$")) + (node-rx (regexp "^(\\S+) \\[(\\S+)\\].*\$.*tags:\\s+([^\$]+)\\)$"))) + (let loop ((inl (get-line)) + (date #f) + (node #f) + (time #f)) + (cond + ((and date time node) ;; have all, return 'em + (close-input-port timeline-port) + (values (common:date-time->seconds (conc date " " time)) node)) + ((and inl (not (eof-object? inl))) ;; have a line to process + (regex-case inl + (date-rx ( _ newdate ) (loop (get-line) newdate node time)) + ;; 22:47:48 [a024d9e60f] Added *user-hash-data* - a global that can be used in -repl and #{scheme ...} calls by the end user (user: matt tags: v1.63) + (node-rx ( _ newtime newnode alltags ) + (let ((tags (string-split-fields ",\\s*" alltags #:infix))) + (print "tags: " tags) + (if (member branch tags) + (loop (get-line) date newnode newtime) + (loop (get-line) date node time)))) + (else ;; have some unrecognised junk? spit out error message + (print "ERROR: fossil timeline returned unrecognisable junk \"" inl "\"") + (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 + (if *action* (cdr (argv)) (argv)) ;; args:get-args dumps first in argv list (the program name) + (map car *arg-keys*) + (map car *switch-keys*) + args:arg-hash + 0)) + +(if (or (member *action* '("-h" "-help" "help" "--help")) + (args:any-defined? "-h" "-help" "--help")) + (begin + (print help) + (exit 1))) + +;; (print "*action*: " *action*) +;; (let-values (((uuid pkt) +;; (command-line->pkt #f args:arg-hash))) +;; (print pkt)) + +;; Add args that use remargs here +;; +(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. + ))) + (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"))) + (begin + (print help) + (exit 1))) + +;;====================================================================== +;; pkts +;;====================================================================== + +(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))) + (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 (load-pkts-to-db mtconf) + (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 + (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 + +;;====================================================================== +;; Runs +;;====================================================================== + +;; make a runname +;; +(define (make-runname pre post) + (time->string + (seconds->local-time (current-seconds)) "%Yw%V.%w-%H%M")) + +;; 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. +;; +;; extra-dat format is ( 'x xval 'y yval .... ) +;; +(define (command-line->pkt action args-alist sched-in #!key (extra-dat '())(area-path #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) + (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 + (meta (if (or pmeta smeta) + (cdr (or pmeta smeta)) ;; found it? + #f))) + (if (or pmeta smeta) ;; construct the switch/param pair. + (list meta value) + '()))) + (filter cdr 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 ".")) + (mtconfig (or (args:get-arg "-config") "megatest.config")) + (mtconfdat (find-and-read-config ;; NB// sets MT_RUN_AREA_HOME as side effect + mtconfig + ;; 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" + (if mtconf + (begin + (configf:section-var-set! mtconf "dyndat" "toppath" start-dir))) + ;; (print "TOPPATH: " (configf:lookup mtconf "dyndat" "toppath")) + mtconfdat)) + + +;; NEED TIMESTAMP ON PKTS for efficient loading of packets into db. + + +;; make a run request pkt from basic data, this seriously needs to be refactored +;; i. Take the code that builds the info to submit to create-run-pkt and have it +;; generate the pkt keys directly. +;; 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) + (let* ((good-val (lambda (inval)(and inval (string? inval)(not (string-null? inval))))) + (area-dat (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)) + (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)) + (print "No mapper " callname " for area " area " using " callname " as the runname")) + (if mapper + (handle-exceptions + exn + (begin + (print-call-chain) + (print "FAILED TO RUN RUNNAME MAPPER " callname " FOR AREA " area) + (print " message: " ((condition-property-accessor 'exn 'message) exn)) + runname) + (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))) + ;; some hacks to remove switches not needed in certain cases + (case (string->symbol (or action "run")) + ((sync) + (set! new-target #f) + (set! runame #f))) + (print "area-path: " area-path " area-xlatr: " area-xlatr " orig-target: " runkey " new-target: " new-target) + (let-values (((uuid pkt) + (command-line->pkt + (if action action "run") + (append + `(("-start-dir" . ,area-path) + ("-msg" . ,reason) + ("-contour" . ,contour)) + (if (good-val new-runname) `(("-run-name" . ,new-runname)) '()) + (if (good-val new-target) `(("-target" . ,new-target)) '()) + (if (good-val mode-patt) `(("-mode-patt" . ,mode-patt)) '()) + (if (good-val tag-expr) `(("-tag-expr" . ,tag-expr)) '()) + (if (good-val dbdest) `(("-sync-to" . ,dbdest)) '()) + (if (good-val append-conf) `(("-append-config" . ,append-conf)) '()) + (if (not (or mode-patt tag-expr)) + `(("-testpatt" . "%")) + '()) + (if (or (not action) + (equal? action "run")) + `(("-preclean" . " ") + ("-rerun-all" . " ")) ;; if run we *always* want preclean set, use single space as placeholder + '()) + ) + sched + extra-dat: `(y ,runkey) ;; we need the run key for marking the run as launched + ))) + (with-output-to-file + (conc pktsdir "/" uuid ".pkt") + (lambda () + (print pkt)))))) + + +(define (val-alist->areas val-alist) + (string-split (or (alist-ref 'areas val-alist) "") ",")) + +(define (area-allowed? area areas) + (or (not areas) + (null? areas) + (member area areas))) + +;; (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 + 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"))) + (contours (configf:get-section mtconf "contours")) + (torun (make-hash-table)) ;; target => ( ... info ... ) + (rgentargs (hash-table-keys rgconf))) ;; these are the targets registered for automatically triggering + + (print "rgentargs: " rgentargs) + + (for-each + (lambda (runkey) + (let* ((keydats (configf:get-section rgconf runkey))) + (for-each + (lambda (sense) ;; these are the sense rules + (let* ((key (car sense)) + (val (cadr sense)) + (keyparts (string-split key ":")) ;; contour:ruletype:action:optional + (contour (car keyparts)) + (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)) + (runname (make-runname "" "")) + (runtrans (alist-ref 'runtrans val-alist)) + + (runstarts (find-pkts pdb '(runstart) `((o . ,contour) + (t . ,runkey)))) + (rspkts (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)))) + ;; 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)))) + ) + + (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))) + + (print "val-alist=" val-alist " runtrans=" runtrans) + + ;; look in runstarts for matching runs by target and contour + ;; get the timestamp for when that run started and pass it + ;; to the rule logic here where "ruletype" will be applied + ;; if it comes back "changed" then proceed to register the runs + + (case (string->symbol (or ruletype "no-such-rule")) + + ((no-such-rule) (print "ERROR: no such rule for " sense)) + + ((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)) + (areas (val-alist->areas val-alist)) + ;; (action (alist-ref 'action val-alist)) + (cron-safe-string (string-translate (string-intersperse (string-split (alist-ref 'cron val-alist)) "-") "*" "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) + (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)))))) + ((run) + (if (common:extended-cron crontab #f last-run) + (push-run-spec torun contour runkey + `((message . ,(conc ruletype ":" cron-safe-string)) + (runname . ,runname) + (runtrans . ,runtrans) + (action . ,action) + (target . ,target))))) + ((remove) + (push-run-spec torun contour runkey + `((message . ,(conc ruletype ":" cron-safe-string)) + (runname . ,runname) + (runtrans . ,runtrans) + (action . ,action) + (target . ,target)))) + (else + (print "ERROR: action \"" action "\" has no scheduled handler") + ))))) + + ((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 + (lambda (cmd) + (print "cmd: " cmd) + (let* ((script (car cmd)) + (params (cdr cmd)) + (cmd (conc script " " contour " " runkey " " std-runname " " action " " params)) + (res (handle-exceptions + exn + #f + (print "Running " cmd) + (with-input-from-pipe cmd read-lines)))) + (if (and res (not (null? res))) + (let* ((parts (string-split (car res))) ;; + (rem-lines (cdr res)) + (num-parts (length parts)) + (last-change (string->number (if (> num-parts 0)(car parts) "abc"))) ;; force no run if not a number returned + (new-target (if (> num-parts 1) + (cadr parts) + runkey)) + (new-runname (if (> num-parts 2) + (caddr parts) + std-runname)) + (message (if (null? rem-lines) + cmd + (string-intersperse rem-lines "-"))) + (need-run (> last-change last-run))) + (print "last-run: " last-run " need-run: " need-run) + (if need-run + (let* ((key-msg `((message . ,(conc ruletype ":" message)) + (runname . ,runname) + (runtrans . ,runtrans) + (action . ,action) + (target . ,new-target)))) + (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) + (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. + (branch (cdr fspec)) + (url-is-file (string-match "^(/|file:).*$" url)) + (fname (conc (common:get-signature url) ".fossil")) + (fdir (conc "/tmp/" (current-user-name) "/mtutil_cache"))) + ;; (if (not url-is-file) ;; need to sync first --- for now, clone 'em all. + (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)) + (runtrans . ,runtrans) + (target . ,runkey))) + (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)) + (runtrans . ,runtrans) + (target . ,runkey))))) + (print "Got datetime=" datetime " node=" node)))) + val-alist)) + + ((file file-or) ;; one or more files must be newer than the reference + (let* ((file-globs (alist-ref 'glob val-alist)) + (areas (val-alist->areas val-alist)) + (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) + (runtrans . ,runtrans) + (target . ,runkey) + (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) + (runtrans . ,runtrans) + (runname . ,runname) + )))))) + ;; starttimes)) + + ((file-and) ;; all files must be newer than the reference + (let* ((file-globs (alist-ref 'glob val-alist)) + (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) + (runtrans . ,runtrans) + (target . ,runkey) + (action . ,action))) + ;; NB// I think this is wrong. It should be looking at last-run only. + (if (> youngestmod last-run) + + ;; (for-each + ;; (lambda (starttime) ;; look at the time the last run was kicked off for this contour + ;; (if (< youngestmod (cdr starttime)) + ;; (set! success #f))) + ;; 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) + (runtrans . ,runtrans) + (target . ,runkey) + (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 (val-alist->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))))) + (for-each + (lambda (runkeydatset) + ;; (print "runkeydatset: ")(pp runkeydatset) + (let ((runkey (car runkeydatset)) + (runkeydats (cadr runkeydatset))) + (for-each + (lambda (runkeydat) + (for-each + (lambda (area) + (if (area-allowed? area areas) ;; is this area to be handled (from areas=a,b,c ...) + (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) (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) + )) + (print "NOTE: skipping " runkeydat " for 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"))) + (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 + res + (begin + (print "ERROR: Unknown key in packet \"" key "\" with value \"" val "\"") + res))))) + (conc "megatest " (if (not (member action '("sync"))) + (conc action " ") + "")) + pkta))) + +;; (use trace)(trace pkt->cmdline) + +(define (write-pkt pktsdir uuid pkt) + (if pktsdir + (with-output-to-file + (conc pktsdir "/" uuid ".pkt") + (lambda () + (print pkt))) + (print "ERROR: cannot process commands without a pkts directory"))) + +;; collect all needed data and create run pkts for contours with changed inputs +;; +(define (dispatch-commands mtconf toppath) + ;; we are expecting a directory "logs", check and create it, create the log in /tmp if not able to create logs dir + (let ((logdir + (if (if (not (directory? "logs")) + (handle-exceptions + exn + #f + (create-directory "logs") + #t) + #t) + "logs" + "/tmp"))) + (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")) + (contours (configf:get-section mtconf "contours")) + (pkts (find-pkts pdb '(cmd) '())) + (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)) + (cmdline (pkt->cmdline pkta)) + (uuid (alist-ref 'Z 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)))) + pkts)))))) + +(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 (common:file-exists? debugcontrolf) + (load debugcontrolf))) + +(if *action* + (case (string->symbol *action*) + ((run remove rerun set-ss archive kill) + (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 (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))) + ;; check a few things + (if (and area + (not area-path)) + (begin + (print "ERROR: the specified area was not found in the [areas] table. Area name=" area) + (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 area-path: area-path))) + (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"))) + (case (string->symbol *action*) + ((process) (begin + (load-pkts-to-db mtconf) + (generate-run-pkts mtconf toppath) + (load-pkts-to-db mtconf) + (dispatch-commands mtconf toppath))) + ((import) (load-pkts-to-db mtconf)) ;; import pkts + ((rungen) (generate-run-pkts mtconf toppath)) + ((dispatch) (dispatch-commands mtconf toppath))))) + ((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 (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 (common:file-exists? schema-file) + (system (conc "/bin/cat " schema-file))))) + ((junk) + (rmt:get-keys)))))))) + +;; If HTTP_HOST is defined then we must be in the cgi environment +;; so run stml and exit +;; +(if (get-environment-variable "HTTP_HOST") + (begin + (stml:main #f) + (exit))) + +(if (or (args:get-arg "-repl") + (args:get-arg "-load")) + (begin + (import extras) ;; might not be needed + ;; (import csi) + (import readline) + (import apropos) + ;; (import (prefix sqlite3 sqlite3:)) ;; doesn't work ... + + (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"))))) ADDED newdashboard.scm Index: newdashboard.scm ================================================================== --- /dev/null +++ newdashboard.scm @@ -0,0 +1,744 @@ +;;====================================================================== +;; Copyright 2006-2013, Matthew Welland. +;; +;; This program is made available under the GNU GPL version 2.0 or +;; greater. See the accompanying file COPYING for details. +;; +;; This program is distributed WITHOUT ANY WARRANTY; without even the +;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR +;; PURPOSE. +;;====================================================================== + +;;====================================================================== +;; Copyright 2006-2016, Matthew Welland. +;; +;; This 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) + +(use (prefix iup iup:)) + +(use canvas-draw) +(import canvas-draw-iup) + +(use sql-de-lite srfi-1 posix regex regex-case srfi-69 typed-records sparse-vectors ;; defstruct + (prefix dbi dbi:)) + +(declare (uses common)) +(declare (uses megatest-version)) +(declare (uses margs)) + +;; (declare (uses launch)) +;; (declare (uses gutils)) +;; (declare (uses db)) +;; (declare (uses server)) +;; (declare (uses synchash)) +(declare (uses dcommon)) +;; (declare (uses tree)) +;; +;; (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 + -server host:port : connect to host:port instead of db access + -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 "-rows" + "-run" + "-test" + "-debug" + "-host" + ) + (list "-h" + "-guimonitor" + "-main" + "-v" + "-q" + ) + args:arg-hash + 0)) + +(if (args:get-arg "-h") + (begin + (print help) + (exit))) + +;; ease debugging by loading ~/.dashboardrc +(let ((debugcontrolf (conc (get-environment-variable "HOME") "/.dashboardrc"))) + (if (common:file-exists? debugcontrolf) + (load debugcontrolf))) + +(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)) + + +;; data for each specific tab goes here +;; +(defstruct dboard:tabdat + ;; runs + ((allruns '()) : list) ;; list of dboard:rundat records + ((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) ;; + ((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 + ((last-test-dat (make-hash-table)) : hash-table) ;; cache last tests dat by run-id + ((run-db-paths (make-hash-table)) : hash-table) ;; cache the paths to the run db files + + ;; Runs view + ((buttondat (make-hash-table)) : hash-table) ;; + ((item-test-names '()) : list) ;; list of itemized tests + ((run-keys (make-hash-table)) : hash-table) + (runs-matrix #f) ;; used in newdashboard + ((start-run-offset 0) : number) ;; left-right slider value + ((start-test-offset 0) : number) ;; up-down slider value + ((runs-btn-height (or (configf:lookup *configdat* "dashboard" "btn-height") "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 + ((all-test-names '()) : list) + + ;; Canvas and drawing data + (cnv #f) + (cnv-obj #f) + (drawing #f) + ((run-start-row 0) : number) + ((max-row 0) : number) + ((running-layout #f) : boolean) + (originx #f) + (originy #f) + ((layout-update-ok #t) : boolean) + ((compact-layout #t) : boolean) + + ;; Run times layout + ;; (graph-button-box #f) ;; RA => Think it is not referenced anywhere + (graph-matrix #f) + ((graph-matrix-table (make-hash-table)) : hash-table) ;; graph-dats referenced thru graph name info + ((graph-cell-table (make-hash-table)) : hash-table) ;; graph-dats referenced thru matrix cell info + ((graph-matrix-row 1) : number) + ((graph-matrix-col 1) : number) + + ;; Controls used to launch runs etc. + ((command "") : string) ;; for run control this is the command being built up + (command-tb #f) ;; widget for the type of command; run, remove-runs etc. + (test-patterns-textbox #f) ;; text box widget for editing a list of test patterns + (key-listboxes #f) + (key-lbs #f) + run-name ;; from run name setting widget + states ;; states for -state s1,s2 ... + statuses ;; statuses for -status s1,s2 ... + + ;; Selector variables + curr-run-id ;; current row to display in Run summary view + prev-run-id ;; previous runid selected before current runid was selected (used in xor-two-runs runs summary mode + curr-test-ids ;; used only in dcommon:run-update which is used in newdashboard + ((filters-changed #t) : boolean) ;; to indicate that the user changed filters for this tab + ((last-filter-str "") : string) ;; conc the target runname and testpatt for a signature of changed filters + ((hide-empty-runs #f) : boolean) + ((hide-not-hide #t) : boolean) ;; toggle for hide/not hide empty runs + (hide-not-hide-button #f) + ((searchpatts (make-hash-table)) : hash-table) ;; + ((state-ignore-hash (make-hash-table)) : hash-table) ;; hash of STATE => #t/#f for display control + ((status-ignore-hash (make-hash-table)) : hash-table) ;; hash of STATUS => #t/#f + (target #f) + (test-patts #f) + + ;; db info to file the .db files for the area + (access-mode (db:get-access-mode)) ;; use cached db or not + (dbdir #f) + (dbfpath #f) + (dbkeys #f) + ((last-db-update (make-hash-table)) : hash-table) ;; last db file timestamp + (monitor-db-path #f) ;; where to find monitor.db + ro ;; is the database read-only? + + ;; tests data + ((num-tests 10) : number) ;; total number of tests to show (used in the old runs display) + + ;; runs tree + ((path-run-ids (make-hash-table)) : hash-table) ;; path (target / runname) => id + (runs-tree #f) + ((runs-tree-ht (make-hash-table)) : hash-table) ;; track which targets added to tree (merge functionality with path-run-ids?) + + ;; tab data + ((view-changed #t) : boolean) + ((xadj 0) : number) ;; x slider number (if using canvas) + ((yadj 0) : number) ;; y slider number (if using canvas) + ;; runs-summary tab state + ((runs-summary-modes '((one-run . "Show One Run") (xor-two-runs . "XOR Two Runs") (xor-two-runs-hide-clean . "XOR; Hide Clean")) ) : list) + ((runs-summary-mode-buttons '()) : list) + ((runs-summary-mode 'one-run) : symbol) + ((runs-summary-mode-change-callbacks '()) : list) + (runs-summary-source-runname-label #f) + (runs-summary-dest-runname-label #f) + ;; runs summary view + + tests-tree ;; used in newdashboard + ) + + + +;; mtest is actually the megatest.config file +;; +(define (mtest toppath window-id) + (let* ((curr-row-num 0) + ;; (rawconfig (read-config (conc toppath "/megatest.config") #f 'return-string)) + (keys-matrix (iup:matrix)) ;; (dcommon:keys-matrix rawconfig)) + (setup-matrix (iup:matrix)) ;; (dcommon:section-matrix rawconfig "setup" "Varname" "Value")) + (jobtools-matrix (iup:matrix + #:expand "YES" + #:numcol 1 + #:numlin 5 + #:numcol-visible 1 + #:numlin-visible 3)) + (validvals-matrix (iup:matrix + #:expand "YES" + #:numcol 1 + #:numlin 2 + #:numcol-visible 1 + #:numlin-visible 2)) + (envovrd-matrix (iup:matrix + #:expand "YES" + #:numcol 1 + #:numlin 20 + #:numcol-visible 1 + #:numlin-visible 8)) + (disks-matrix (iup:matrix + #:expand "YES" + #:numcol 1 + #:numlin 20 + #:numcol-visible 1 + #:numlin-visible 8)) + ) + (iup:attribute-set! disks-matrix "0:0" "Disk Name") + (iup:attribute-set! disks-matrix "0:1" "Disk Path") + (iup:attribute-set! disks-matrix "WIDTH1" "120") + (iup:attribute-set! disks-matrix "WIDTH0" "100") + (iup:attribute-set! disks-matrix "ALIGNMENT1" "ALEFT") + (iup:attribute-set! disks-matrix "FIXTOTEXT" "C1") + (iup:attribute-set! disks-matrix "RESIZEMATRIX" "YES") + + ;; fill in existing info + (for-each + (lambda (mat fname) + (set! curr-row-num 1) + (for-each + (lambda (var) + (iup:attribute-set! mat (conc curr-row-num ":0") var) + ;; (iup:attribute-set! mat (conc curr-row-num ":1") (config-lookup rawconfig fname var)) + (set! curr-row-num (+ curr-row-num 1))) + '()));; (configf:section-vars rawconfig fname))) + (list setup-matrix jobtools-matrix validvals-matrix envovrd-matrix disks-matrix) + (list "setup" "jobtools" "validvalues" "env-override" "disks")) + + (for-each + (lambda (mat) + (iup:attribute-set! mat "0:1" "Value") + (iup:attribute-set! mat "0:0" "Var") + (iup:attribute-set! mat "ALIGNMENT1" "ALEFT") + (iup:attribute-set! mat "FIXTOTEXT" "C1") + (iup:attribute-set! mat "RESIZEMATRIX" "YES") + (iup:attribute-set! mat "WIDTH1" "120") + (iup:attribute-set! mat "WIDTH0" "100") + ) + (list setup-matrix jobtools-matrix validvals-matrix envovrd-matrix)) + + (iup:attribute-set! validvals-matrix "WIDTH1" "290") + (iup:attribute-set! envovrd-matrix "WIDTH1" "290") + + (iup:vbox + (iup:hbox + + (iup:vbox + (let ((tabs (iup:tabs + ;; The required tab + (iup:hbox + ;; The keys + (iup:frame + #:title "Keys (required)" + (iup:vbox + (iup:label (conc "Set the fields for organising your runs\n" + "here. Note: can only be changed before\n" + "running the first run when megatest.db\n" + "is created.")) + keys-matrix)) + (iup:vbox + ;; The setup section + (iup:frame + #:title "Setup" + (iup:vbox + (iup:label (conc "max_concurrent_jobs : limits total concurrent jobs (optional)\n" + "linktree : directory where linktree will be created.")) + setup-matrix)) + ;; The jobtools + (iup:frame + #:title "Jobtools" + (iup:vbox + (iup:label (conc "launcher : tool or script to run jobs (try nbfake)\n" + "useshell : use system to run your launcher\n" + "workhosts : spread jobs out on these hosts")) + jobtools-matrix)) + ;; The disks + (iup:frame + #:title "Disks" + (iup:vbox + (iup:label (conc "Enter names and existing paths of locations to run tests")) + disks-matrix)))) + ;; The optional tab + (iup:vbox + ;; The Environment Overrides + (iup:frame + #:title "Env override" + envovrd-matrix) + ;; The valid values + (iup:frame + #:title "Validvalues" + validvals-matrix) + )))) + (iup:attribute-set! tabs "TABTITLE0" "Required settings") + (iup:attribute-set! tabs "TABTITLE1" "Optional settings") + tabs)) + )))) + +;; The runconfigs.config file +;; +(define (rconfig window-id) + (iup:vbox + (iup:frame #:title "Default"))) + +;;====================================================================== +;; T E S T S +;;====================================================================== + +(define (tree-path->test-id path) + (if (not (null? path)) + (hash-table-ref/default (dboard:data-path-test-ids *data*) path #f) + #f)) + +(define (test-panel window-id) + (let* ((curr-row-num 0) + (viewlog (lambda (x) + (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) + (let ((shell (if (get-environment-variable "SHELL") + (conc "-e " (get-environment-variable "SHELL")) + ""))) + (system (conc "cd " rundir + ";xterm -T \"" (string-translate testfullname "()" " ") "\" " shell "&"))) + (message-window (conc "Directory " rundir " not found"))))) + (command-text-box (iup:textbox #:expand "HORIZONTAL" #:font "Courier New, -12")) + (command-launch-button (iup:button "Execute!" + ;; #:expand "HORIZONTAL" + #:size "50x" + #:action (lambda (x) + (let ((cmd (iup:attribute command-text-box "VALUE"))) + (system (conc cmd " &")))))) + (run-test (lambda (x) + (iup:attribute-set! + command-text-box "VALUE" + (conc "xterm -geometry 180x20 -e \"megatest -target " keystring " :runname " runname + " -runtests " (conc testname "/" (if (equal? item-path "") + "%" + item-path)) + ";echo Press any key to continue;bash -c 'read -n 1 -s'\"")))) + (remove-test (lambda (x) + (iup:attribute-set! + command-text-box "VALUE" + (conc "xterm -geometry 180x20 -e \"megatest -remove-runs -target " keystring " :runname " runname + " -testpatt " (conc testname "/" (if (equal? item-path "") + "%" + item-path)) + " -v;echo Press any key to continue;bash -c 'read -n 1 -s'\"")))) + (run-info-matrix (iup:matrix + #:expand "YES" + ;; #:scrollbar "YES" + #:numcol 1 + #:numlin 4 + #:numcol-visible 1 + #:numlin-visible 4 + #:click-cb (lambda (obj lin col status) + (print "obj: " obj " lin: " lin " col: " col " status: " status)))) + (test-info-matrix (iup:matrix + #:expand "YES" + #:numcol 1 + #:numlin 7 + #:numcol-visible 1 + #:numlin-visible 7)) + (test-run-matrix (iup:matrix + #:expand "YES" + #:numcol 1 + #:numlin 5 + #:numcol-visible 1 + #:numlin-visible 5)) + (meta-dat-matrix (iup:matrix + #:expand "YES" + #:numcol 1 + #:numlin 5 + #:numcol-visible 1 + #:numlin-visible 5)) + (steps-matrix (iup:matrix + #:expand "YES" + #:numcol 6 + #:numlin 50 + #:numcol-visible 6 + #:numlin-visible 8)) + (data-matrix (iup:matrix + #:expand "YES" + #:numcol 8 + #:numlin 50 + #:numcol-visible 8 + #:numlin-visible 8)) + (updater (lambda (testdat) + (test-update window-id testdat run-info-matrix test-info-matrix test-run-matrix meta-dat-matrix steps-matrix data-matrix)))) + + ;; Set the updater in updaters + ;; (hash-table-set! (dboard:data-updaters *data*) window-id updater) + ;; + (for-each + (lambda (mat) + ;; (iup:attribute-set! mat "0:1" "Value") + ;; (iup:attribute-set! mat "0:0" "Var") + (iup:attribute-set! mat "HEIGHT0" 0) + (iup:attribute-set! mat "ALIGNMENT1" "ALEFT") + ;; (iup:attribute-set! mat "FIXTOTEXT" "C1") + (iup:attribute-set! mat "RESIZEMATRIX" "YES")) + ;; (iup:attribute-set! mat "WIDTH1" "120") + ;; (iup:attribute-set! mat "WIDTH0" "100")) + (list run-info-matrix test-info-matrix test-run-matrix meta-dat-matrix)) + + ;; Steps matrix + (iup:attribute-set! steps-matrix "0:1" "Step Name") + (iup:attribute-set! steps-matrix "0:2" "Start") + (iup:attribute-set! steps-matrix "WIDTH2" "40") + (iup:attribute-set! steps-matrix "0:3" "End") + (iup:attribute-set! steps-matrix "WIDTH3" "40") + (iup:attribute-set! steps-matrix "0:4" "Status") + (iup:attribute-set! steps-matrix "WIDTH4" "40") + (iup:attribute-set! steps-matrix "0:5" "Duration") + (iup:attribute-set! steps-matrix "WIDTH5" "40") + (iup:attribute-set! steps-matrix "0:6" "Log File") + (iup:attribute-set! steps-matrix "ALIGNMENT1" "ALEFT") + ;; (iup:attribute-set! steps-matrix "FIXTOTEXT" "C1") + (iup:attribute-set! steps-matrix "RESIZEMATRIX" "YES") + ;; (iup:attribute-set! steps-matrix "WIDTH1" "120") + ;; (iup:attribute-set! steps-matrix "WIDTH0" "100") + + ;; Data matrix + ;; + (let ((rownum 1)) + (for-each + (lambda (x) + (iup:attribute-set! data-matrix (conc "0:" rownum) x) + (iup:attribute-set! data-matrix (conc "WIDTH" rownum) "50") + (set! rownum (+ rownum 1))) + (list "Category" "Variable" "Value" "Expected" "Tolerance" "Status" "Units" "Type" "Comment"))) + (iup:attribute-set! data-matrix "REDRAW" "ALL") + + (for-each + (lambda (data) + (let ((mat (car data)) + (keys (cadr data)) + (rownum 1)) + (for-each + (lambda (key) + (iup:attribute-set! mat (conc rownum ":0") key) + (set! rownum (+ rownum 1))) + keys) + (iup:attribute-set! mat "REDRAW" "ALL"))) + (list + (list run-info-matrix '("Run Id" "Target" "Runname" "Run Start Time" )) + (list test-info-matrix '("Test Id" "Testname" "Itempath" "State" "Status" "Test Start Time" "Comment")) + (list test-run-matrix '("Hostname" "Host info" "Disk Free" "CPU Load" "Run Duration")) + (list meta-dat-matrix '("Author" "Owner" "Last Reviewed" "Tags" "Description")))) + + (iup:split + #:orientation "HORIZONTAL" + (iup:vbox + (iup:hbox + (iup:vbox + run-info-matrix + test-info-matrix) + ;; test-info-matrix) + (iup:vbox + test-run-matrix + meta-dat-matrix)) + (iup:vbox + (iup:vbox + (iup:hbox + (iup:button "View Log" #:action viewlog #:size "60x" ) ;; #:size "30x" + (iup:button "Start Xterm" #:action xterm #:size "60x" )) ;; #:size "30x" + (iup:hbox + (iup:button "Run Test" #:action run-test #:size "60x" ) ;; #:size "30x" + (iup:button "Clean Test" #:action remove-test #:size "60x" ))) ;; #:size "30x" + (iup:hbox + ;; hiup:split ;; hbox + ;; #:orientation "HORIZONTAL" + ;; #:value 300 + command-text-box + command-launch-button))) + (iup:vbox + (let ((tabs (iup:tabs + steps-matrix + data-matrix))) + (iup:attribute-set! tabs "TABTITLE0" "Test Steps") + (iup:attribute-set! tabs "TABTITLE1" "Test Data") + tabs))))) + +;; Test browser +(define (tests window-id) + (iup:split + (let* ((tb (iup:treebox + #:selection-cb + (lambda (obj id state) + ;; (print "obj: " obj ", id: " id ", state: " state) + (let* ((run-path (tree:node->path obj id)) + (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) + (test-panel window-id))) + +;; The function to update the fields in the test view panel +(define (test-update window-id testdat run-info-matrix test-info-matrix test-run-matrix meta-dat-matrix steps-matrix data-matrix) + ;; get test-id + ;; then get test record + (if testdat + (let* ((test-id 0) ;; (hash-table-ref/default (dboard:data-curr-test-ids *data*) window-id #f)) + (test-data (hash-table-ref/default testdat test-id #f)) + (run-id (db:test-get-run_id test-data)) + (targ/runname (hash-table-ref/default (dboard:data-run-keys *data*) + run-id + '())) + (target (if (null? targ/runname) "" (string-intersperse (reverse (cdr (reverse targ/runname))) "/"))) + (runname (if (null? targ/runname) "" (car (cdr targ/runname)))) + (steps-dat (tests:get-compressed-steps *dbstruct-local* run-id test-id))) + + (if test-data + (begin + ;; + (for-each + (lambda (data) + (let ((mat (car data)) + (vals (cadr data)) + (rownum 1)) + (for-each + (lambda (key) + (let ((cell (conc rownum ":1"))) + (if (not (equal? (iup:attribute mat cell)(conc key))) + (begin + ;; (print "setting cell " cell " in matrix " mat " to value " key) + (iup:attribute-set! mat cell (conc key)) + (iup:attribute-set! mat "REDRAW" cell))) + (set! rownum (+ rownum 1)))) + vals))) + (list + (list run-info-matrix + (if test-id + (list (db:test-get-run_id test-data) + target + runname + "n/a") + (make-list 4 ""))) + (list test-info-matrix + (if test-id + (list test-id + (db:test-get-testname test-data) + (db:test-get-item-path test-data) + (db:test-get-state test-data) + (db:test-get-status test-data) + (seconds->string (db:test-get-event_time test-data)) + (db:test-get-comment test-data)) + (make-list 7 ""))) + (list test-run-matrix + (if test-id + (list (db:test-get-host test-data) + (db:test-get-uname test-data) + (db:test-get-diskfree test-data) + (db:test-get-cpuload test-data) + (seconds->hr-min-sec (db:test-get-run_duration test-data))) + (make-list 5 ""))) + )) + (dcommon:populate-steps steps-dat steps-matrix)))))) + ;;(list meta-dat-matrix + ;; (if test-id + ;; (list ( + + +;; db:test-get-id +;; db:test-get-run_id +;; db:test-get-testname +;; db:test-get-state +;; db:test-get-status +;; db:test-get-event_time +;; db:test-get-host +;; db:test-get-cpuload +;; db:test-get-diskfree +;; db:test-get-uname +;; db:test-get-rundir +;; db:test-get-item-path +;; db:test-get-run_duration +;; db:test-get-final_logf +;; db:test-get-comment +;; db:test-get-fullname + + +;;====================================================================== +;; R U N C O N T R O L +;;====================================================================== + +;; Overall runs browser +;; +(define (runs window-id) + (let* ((runs-matrix (iup:matrix + #:expand "YES" + ;; #:fittosize "YES" + #:scrollbar "YES" + #:numcol 100 + #:numlin 100 + #:numcol-visible 7 + #:numlin-visible 7 + #:click-cb (lambda (obj lin col status) + (print "obj: " obj " lin: " lin " col: " col " status: " status))))) + + (iup:attribute-set! runs-matrix "RESIZEMATRIX" "YES") + (iup:attribute-set! runs-matrix "WIDTH0" "100") + + ;; (dboard:data-runs-matrix-set! *data* runs-matrix) + (iup:hbox + (iup:frame + #:title "Runs browser" + (iup:vbox + runs-matrix))))) + +;; Browse and control a single run +;; +(define (runcontrol window-id) + (iup:hbox)) + +;;====================================================================== +;; D A S H B O A R D +;;====================================================================== + +;; Main Panel +(define (main-panel window-id) + (iup:dialog + #:title "Megatest Control Panel" + #:menu (dcommon:main-menu) + #:shrink "YES" + (let ((tabtop (iup:tabs + (runs window-id) + (tests window-id) + (runcontrol window-id) + (mtest *toppath* window-id) + (rconfig window-id) + ))) + (iup:attribute-set! tabtop "TABTITLE0" "Runs") + (iup:attribute-set! tabtop "TABTITLE1" "Tests") + (iup:attribute-set! tabtop "TABTITLE2" "Run Control") + (iup:attribute-set! tabtop "TABTITLE3" "megatest.config") + (iup:attribute-set! tabtop "TABTITLE4" "runconfigs.config") + tabtop))) + +(define *current-window-id* 0) + +(define (newdashboard dbstruct) + (let* ((data (make-hash-table)) + (keys '()) ;; (db:get-keys dbstruct)) + (runname "%") + (testpatt "%") + (keypatts '()) ;; (map (lambda (k)(list k "%")) keys)) + (states '()) + (statuses '()) + (nextmintime (current-milliseconds)) + (my-window-id *current-window-id*)) + (set! *current-window-id* (+ 1 *current-window-id*)) + ;; (dboard:data-runs-set! *data* data) ;; make this data available to the rest of the application + (iup:show (main-panel my-window-id)) + ;; Yes, running iup:show will pop up a new panel + ;; (iup:show (main-panel my-window-id)) + (iup:callback-set! *tim* + "ACTION_CB" + (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)) + (endtime (current-milliseconds))) + (set! nextmintime (+ endtime (* 2 (- endtime starttime)))) + ;; (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 @@ -197,11 +197,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: portlogger.scm ================================================================== --- portlogger.scm +++ portlogger.scm @@ -19,11 +19,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 +56,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) @@ -99,24 +99,24 @@ (sqlite3:finalize! qry3) res)) (define (portlogger:get-prev-used-port db) (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)) - (print-call-chain (current-error-port)) - (debug:print 0 *default-log-port* "Continuing anyway.") - #f) - (sqlite3:fold-row - (lambda (var curr) - (or curr var curr)) - #f - db - "SELECT (port) FROM ports WHERE state='released' LIMIT 1;"))) + 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 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) + (or curr var curr)) + #f + db + "SELECT (port) FROM ports WHERE state='released' LIMIT 1;"))) (define (portlogger:find-port db) (let* ((lowport (let ((val (configf:lookup *configdat* "server" "lowport"))) (if (and val (string->number val)) @@ -128,11 +128,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 +158,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 @@ -53,11 +53,11 @@ (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)) @@ -143,11 +143,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: rmt.scm ================================================================== --- rmt.scm +++ rmt.scm @@ -1,7 +1,7 @@ ;;====================================================================== -;; Copyright 2006-2013, Matthew Welland. +;; 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 @@ -11,11 +11,11 @@ (use format typed-records) ;; RADT => purpose of json format?? (declare (unit rmt)) (declare (uses api)) -(declare (uses tdb)) +;; (declare (uses tdb)) (declare (uses http-transport)) ;;(declare (uses nmsg-transport)) (include "common_records.scm") ;; @@ -31,148 +31,262 @@ ;;====================================================================== ;; if a server is either running or in the process of starting call client:setup ;; else return #f to let the calling proc know that there is no server available ;; -(define (rmt:get-connection-info areapath) ;; TODO: push areapath down. - (let ((cinfo (remote-conndat *runremote*)) - (run-id 0)) - (if cinfo - cinfo - (if (server:check-if-running areapath) - (client:setup areapath) - #f)))) +(define (rmt:get-connection-info areapath #!key (area-dat #f)) ;; TODO: push areapath down. + (let* ((runremote (or area-dat *runremote*)) + (cinfo (if (remote? runremote) + (remote-conndat runremote) + #f))) + (if cinfo + cinfo + (if (server:check-if-running areapath) + (client:setup areapath) + #f)))) (define *send-receive-mutex* (make-mutex)) ;; should have separate mutex per run-id ;; RA => e.g. usage (rmt:send-receive 'get-var #f (list varname)) ;; -(define (rmt:send-receive cmd rid params #!key (attemptnum 1)) ;; start attemptnum at 1 so the modulo below works as expected +(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* + + ;; 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 + (let* ((start-time (current-seconds)) ;; snapshot time so all use cases get same value + (areapath *toppath*);; TODO - resolve from dbstruct to be compatible with multiple areas + (runremote (or area-dat + *runremote*)) + (readonly-mode (if (and runremote + (remote-ro-mode-checked runremote)) + (remote-ro-mode runremote) + (let* ((dbfile (conc *toppath* "/megatest.db")) + (ro-mode (not (file-write-access? dbfile)))) ;; TODO: use dbstruct or runremote to figure this out in future + (if runremote + (begin + (remote-ro-mode-set! runremote ro-mode) + (remote-ro-mode-checked-set! runremote #t) + ro-mode) + ro-mode))))) + + ;; 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)) - ;; 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 30)))) ;; add 30 seconds of noise so that not all running tests expire at the same time causing a storm of server starts - (< (http-transport:server-dat-get-last-access (remote-conndat *runremote*)) expire-time))) - (debug:print-info 12 *default-log-port* "rmt:send-receive, case 8") - (remote-conndat-set! *runremote* #f) - (mutex-unlock! *rmt-mutex*) - (rmt:send-receive cmd rid params attemptnum: attemptnum)) - ;; ensure we have a record for our connection for given area - ((not *runremote*) - (set! *runremote* (make-remote)) - (mutex-unlock! *rmt-mutex*) - (debug:print-info 12 *default-log-port* "rmt:send-receive, case 1") - (rmt:send-receive cmd rid params attemptnum: attemptnum)) - ;; ensure we have a homehost record - ((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)) - (mutex-unlock! *rmt-mutex*) - (debug:print-info 12 *default-log-port* "rmt:send-receive, case 2") - (rmt:send-receive cmd rid params attemptnum: attemptnum)) - ;; on homehost and this is a read - ((and (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") - (rmt:open-qry-close-locally cmd 0 params)) - - ;; 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:check-if-running *toppath*))) ;; server has died. - (set! *runremote* (make-remote)) - (mutex-unlock! *rmt-mutex*) - (debug:print-info 12 *default-log-port* "rmt:send-receive, case 4.1") - (rmt:send-receive cmd rid params attemptnum: attemptnum)) - - ;; on homehost and this is a write, we already have a server - ((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 - (mutex-unlock! *rmt-mutex*) - (debug:print-info 12 *default-log-port* "rmt:send-receive, case 4") - (rmt:open-qry-close-locally cmd 0 params)) - - ;; on homehost, no server contact made and this is a write, passively start a server - ((and (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") - (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 - (server:kind-run *toppath*))) - (mutex-unlock! *rmt-mutex*) - (debug:print-info 12 *default-log-port* "rmt:send-receive, case 5.1") - (rmt:open-qry-close-locally cmd 0 params)) - - ((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*)) - (mutex-unlock! *rmt-mutex*) - (server:start-and-wait *toppath*) - (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 - ;; all set up if get this far, dispatch the query - ((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") - (rmt:open-qry-close-locally cmd (if rid rid 0) params)) - - ;; not on homehost, do server query - (else - (mutex-unlock! *rmt-mutex*) - (debug:print-info 12 *default-log-port* "rmt:send-receive, case 9") - (mutex-lock! *rmt-mutex*) - (let* ((conninfo (remote-conndat *runremote*)) - (dat (case (remote-transport *runremote*) + + ;;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 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 3") + (debug:print 0 *default-log-port* "WARNING: write transaction requested on a readonly area. cmd="cmd" params="params) + #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) + (> (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, 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 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 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, 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.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, 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 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 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-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 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*) + (debug:print-info 12 *default-log-port* "rmt:send-receive, case 9") + ;; (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")) ((exn)(vector #f "other fail" (print-call-chain))))) (else - (debug:print 0 *default-log-port* "ERROR: transport " (remote-transport *runremote*) " not supported") + (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 12 *default-log-port* "rmt:send-receive, case 9. conninfo=" conninfo " dat=" dat " *runremote* = "*runremote*) - (if success - (case (remote-transport *runremote*) - ((http) - (mutex-unlock! *rmt-mutex*) - res) - (else - (debug:print 0 *default-log-port* "ERROR: transport " (remote-transport *runremote*) " is unknown") - (mutex-unlock! *rmt-mutex*) - (exit 1))) + (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) - (remote-server-url-set! *runremote* #f) - (debug:print-info 12 *default-log-port* "rmt:send-receive, case 9.1") + (mutex-lock! *rmt-mutex*) + (remote-conndat-set! runremote #f) + (http-transport:close-connections area-dat: runremote) + (remote-server-url-set! runremote #f) (mutex-unlock! *rmt-mutex*) - (server:start-and-wait *toppath*) + (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 @@ -228,15 +342,25 @@ 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)) - (api:execute-requests dbstruct-local (vector (symbol->string cmd) params)) + (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.. + exn ;; This is an attempt to detect that situation and recover gracefully + (begin + (debug:print0 *default-log-port* "ERROR: bad data from server " v " message: " ((condition-property-accessor 'exn 'message) exn)) + (vector #t '())) ;; should always get a vector but if something goes wrong return a dummy + (if (and (vector? v) + (> (vector-length v) 1)) + (let ((newvec (vector (vector-ref v 0)(vector-ref v 1)))) + newvec) ;; by copying the vector while inside the error handler we should force the detection of a corrupted record + (vector #t '())))) ;; we could also check that the returned types are valid (vector #t '()))) (success (vector-ref resdat 0)) (res (vector-ref resdat 1)) (duration (- (current-milliseconds) start))) (if (and read-only qry-is-write) @@ -254,11 +378,11 @@ ;; (rmt:update-db-stats run-id cmd params duration) ;; mark this run as dirty if this was a write, the watchdog is responsible for syncing it (if qry-is-write (let ((start-time (current-seconds))) (mutex-lock! *db-multi-sync-mutex*) - (set! *db-last-access* start-time) ;; THIS IS PROBABLY USELESS? (we are on a client) +/ (set! *db-last-access* start-time) ;; THIS IS PROBABLY USELESS? (we are on a client) (mutex-unlock! *db-multi-sync-mutex*))))) res)) (define (rmt:send-receive-no-auto-client-setup connection-info cmd run-id params) (let* ((run-id (if run-id run-id 0)) @@ -333,10 +457,13 @@ ;; NOT COMPLETED (define (rmt:runtests user run-id testpatt params) (rmt:send-receive 'runtests run-id testpatt)) +(define (rmt:get-changed-record-ids since-time) + (rmt:send-receive 'get-changed-record-ids #f (list since-time)) ) + ;;====================================================================== ;; T E S T M E T A ;;====================================================================== (define (rmt:get-tests-tags) @@ -386,12 +513,14 @@ (rmt:general-call 'register-test run-id run-id test-name item-path)) (define (rmt:get-test-id run-id testname item-path) (rmt:send-receive 'get-test-id run-id (list run-id testname item-path))) +;; run-id is NOT used +;; (define (rmt:get-test-info-by-id run-id test-id) - (if (and (number? run-id)(number? test-id)) + (if (number? test-id) (rmt:send-receive 'get-test-info-by-id run-id (list run-id test-id)) (begin (debug:print 0 *default-log-port* "WARNING: Bad data handed to rmt:get-test-info-by-id run-id=" run-id ", test-id=" test-id) (print-call-chain (current-error-port)) #f))) @@ -408,20 +537,20 @@ ;; WARNING: This currently bypasses the transaction wrapped writes system (define (rmt:test-set-state-status-by-id run-id test-id newstate newstatus newcomment) (rmt:send-receive 'test-set-state-status-by-id run-id (list run-id test-id newstate newstatus newcomment))) -(define (rmt:set-tests-state-status run-id testnames currstate currstatus newstate newstatus) +(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))) @@ -561,12 +690,12 @@ (define (rmt:get-num-runs runpatt) (rmt:send-receive 'get-num-runs #f (list runpatt))) ;; Use the special run-id == #f scenario here since there is no run yet -(define (rmt:register-run keyvals runname state status user) - (rmt:send-receive 'register-run #f (list keyvals runname state status user))) +(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) (rmt:send-receive 'get-run-name-from-id run-id (list run-id))) (define (rmt:delete-run run-id) @@ -611,10 +740,13 @@ (rmt:send-receive 'get-main-run-stats #f (list run-id))) (define (rmt:get-var varname) (rmt:send-receive 'get-var #f (list varname))) +(define (rmt:del-var varname) + (rmt:send-receive 'del-var #f (list varname))) + (define (rmt:set-var varname value) (rmt:send-receive 'set-var #f (list varname value))) ;;====================================================================== ;; M U L T I R U N Q U E R I E S @@ -690,10 +822,13 @@ ;; 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))) +(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))) + ;; (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) ;; '()))) @@ -725,10 +860,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: runconfig.scm ================================================================== --- runconfig.scm +++ runconfig.scm @@ -8,10 +8,15 @@ (declare (unit runconfig)) (declare (uses common)) (include "common_records.scm") +(define (runconfig:read fname target environ-patt) + (let ((ht (make-hash-table))) + (if target (hash-table-set! ht target '())) + (read-config fname ht #t environ-patt: environ-patt sections: (if target (list "default" target) #f)))) + ;; NB// to process a runconfig ensure to use environ-patt with target! ;; (define (setup-env-defaults fname run-id already-seen keyvals #!key (environ-patt #f)(change-env #t)) (let* ((keys (map car keyvals)) (thekey (if keyvals @@ -21,11 +26,11 @@ (begin (debug:print-error 0 *default-log-port* "setup-env-defaults called with no run-id or -target or -reqtarg") "nothing matches this I hope")))) ;; Why was system disallowed in the reading of the runconfigs file? ;; NOTE: Should be setting env vars based on (target|default) - (confdat (read-config fname #f #t environ-patt: environ-patt sections: (list "default" thekey))) + (confdat (runconfig:read fname thekey environ-patt)) (whatfound (make-hash-table)) (finaldat (make-hash-table)) (sections (list "default" thekey))) (if (not *target*)(set! *target* thekey)) ;; may save a db access or two but repeats db:get-target code (debug:print 4 *default-log-port* "Using key=\"" thekey "\"") @@ -51,11 +56,11 @@ (hash-table-set! finaldat envvar val))) (map car section-dat))))) sections) (if already-seen (begin - (debug:print 2 *default-log-port* "Key settings found in runconfig.config:") + (debug:print 2 *default-log-port* "Key settings found in runconfigs.config:") (for-each (lambda (fullkey) (debug:print 2 *default-log-port* (format #f "~20a ~a\n" fullkey (hash-table-ref/default whatfound fullkey 0)))) sections) (debug:print 2 *default-log-port* "---") (set! *already-seen-runconfig-info* #t))) @@ -68,13 +73,75 @@ (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 ")") ")"))) (debug:print 0 *default-log-port* "WARNING: You do not have a run config file: " runconfigf)))) - + +;; given (a (b c) d) return ((a b d)(a c d)) +;; NOTE: this feels like it has been done before - perhaps with items handling? +;; +(define (runconfig:combinations inlst) + (let loop ((hed (car inlst)) + (tal (cdr inlst)) + (res '())) + ;; (print "res: " res " hed: " hed) + (if (list? hed) + (let ((newres (if (null? res) ;; first time through convert incoming items to list of items + (map list hed) + (apply append + (map (lambda (r) ;; iterate over items in res + (map (lambda (h) ;; iterate over items in hed + (append r (list h))) + hed)) + res))))) + ;; (print "newres1: " newres) + (if (null? tal) + newres + (loop (car tal)(cdr tal) newres))) + (let ((newres (if (null? res) + (list (list hed)) + (map (lambda (r) + (append r (list hed))) + res)))) + ;; (print "newres2: " newres) + (if (null? tal) + newres + (loop (car tal)(cdr tal) newres)))))) + +;; multi-part expand +;; Given a/b,c,d/e,f return a/b/e a/b/f a/c/e a/c/f a/d/e a/d/f +;; +(define (runconfig:expand target) + (let* ((parts (map (lambda (x) + (string-split x ",")) + (string-split target "/")))) + (map (lambda (x) + (string-intersperse x "/")) + (runconfig:combinations parts)))) + +;; multi-target expansion +;; a/b/c/x,y,z a/b/d/x,y => a/b/c/x a/b/c/y a/b/c/z a/b/d/x a/b/d/y +;; +(define (runconfig:expand-target target-strs) + (delete-duplicates + (apply append (map runconfig:expand (string-split target-strs " "))))) + +#| + (if (null? target-strs) + '() + (let loop ((hed (car target-strs)) + (tal (cdr target-strs)) + (res '())) + ;; first break all parts into individual target patterns + (if (string-index hed " ") ;; this is a multi-target target + (let ((newres (append (string-split hed " ") res))) + (runconfig:expand-target newres)) + (if (string-index hed ",") ;; this is a multi-target where one or more parts are comma separated + +|# ADDED runconfigs.config Index: runconfigs.config ================================================================== --- /dev/null +++ runconfigs.config @@ -0,0 +1,92 @@ +# To get emacs font highlighing in the various megatest configs do this: +# +# Install emacs-goodies-el: +# sudo apt install emacs-goodies-el +# Add to your ~/.emacs file: +# (add-to-list 'auto-mode-alist '("config\\'" . conf-space-mode)) +# + +# example of a cron entry to run sync using db spec pgdb, with pgdb setting in file local.config +# +[a/b/c] +all:scheduled:sync cron= 0/5 * * * *;dbdest=pgdb;appendconf=/nfs/phoebe/disk1/home/mfs/matt/.sysmaint/local.config +quick:scheduled:sync cron= 0/5 * * * *;dbdest=pgdb;appendconf=/nfs/phoebe/disk1/home/mfs/matt/.sysmaint/local.config + +[scriptinc ./gentargets.sh #{getenv USER}] +# [v1.23/45/67] + +# tip will be replaced with hashkey? + +# [%/%/%] doesn't work + +[/.*/] + +# [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 + +# 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 + +# field allowed values +# ----- -------------- +# minute 0-59 +# hour 0-23 +# day of month 1-31 +# month 1-12 (or names, future development) +# day of week 0-7 (0 or 7 is Sun, or, future development, use names) + +# actions: +# run - run a testsuite +# clean - clear out runs +# archive - archive runs + +# quick:scheduled:run cron=47 * * * * ;run-name=auto +# quick:scheduled:archive cron=15 20 * * * ;run-name=%;target=%/%/% + +# [%] +# # every friday at midnight clean "all" tests over 7d +# all:scheduled:clean cron= 0 0 0 0 5;run-name=%;age=7d + +# [v1.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 run-name=auto;glob=*.scm +# quick:file:clean run-name=auto; +# quick:script:run run-name=auto;script=checkfossil.sh v1.63 +# +# # field allowed values +# # ----- -------------- +# # minute 0-59 +# # hour 0-23 +# # day of month 1-31 +# # month 1-12 (or names, future development) +# # day of week 0-7 (0 or 7 is Sun, or, future development, use names) +# +# # actions: +# # run - run a testsuite +# # clean - clear out runs +# # archive - archive runs +# +# quick:scheduled:run cron=47 * * * * ;run-name=auto +# quick:scheduled:archive cron=15 20 * * * ;run-name=% ; +# +# [%/%/%] +# # every friday at midnight clean "all" tests over 7d +# all:scheduled:clean cron= 0 0 0 0 5;run-name=%;age=7d +# Index: runs.scm ================================================================== --- runs.scm +++ runs.scm @@ -50,17 +50,18 @@ waitons testmode newtal itemmaps prereqs-not-met) ;; 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 (common:args-get-target) (get-environment-variable "MT_TARGET"))) (keys (if inkeys inkeys (rmt:get-keys))) (keyvals (if inkeyvals inkeyvals (keys:target->keyval keys target))) (vals (hash-table-ref/default *env-vars-by-run-id* run-id #f)) - (link-tree (configf:lookup *configdat* "setup" "linktree"))) + (link-tree (common:get-linktree))) ;; (configf:lookup *configdat* "setup" "linktree"))) (if testname (setenv "MT_TEST_NAME" testname)) (if itempath (setenv "MT_ITEMPATH" itempath)) ;; get the info from the db and put it in the cache (if link-tree @@ -73,26 +74,61 @@ (for-each (lambda (key) (hash-table-set! vals (car key) (cadr key))) keyvals))) ;; from the cached data set the vars + (hash-table-for-each vals (lambda (key val) (debug:print 2 *default-log-port* "setenv " key " " val) (safe-setenv key val))) + ;;(bb-check-path msg: "runs:set-megatest-env-vars block 1") + ;;(BB> "*env-vars-by-run-id*/runid("run-id" vals="(hash-table->alist vals)) + (if (not (get-environment-variable "MT_TARGET"))(setenv "MT_TARGET" target)) - (alist->env-vars (hash-table-ref/default *configdat* "env-override" '())) + ;; we had a case where there was an exception generated by the hash-table-ref + ;; due to *configdat* being #f Adding a handle and exit + (let fatal-loop ((count 0)) + (handle-exceptions + exn + (let ((call-chain (get-call-chain)) + (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))) + (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 () + (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 (setenv "MT_RUNNAME" runname) (debug:print-error 0 *default-log-port* "no value for runname for id " run-id))) (setenv "MT_RUN_AREA_HOME" *toppath*) ;; if a testname and itempath are available set the remaining appropriate variables (if testname (setenv "MT_TEST_NAME" testname)) (if itempath (setenv "MT_ITEMPATH" itempath)) + ;;(bb-check-path msg: "runs:set-megatest-env-vars block 3") (if (and testname link-tree) (setenv "MT_TEST_RUN_DIR" (conc (getenv "MT_LINKTREE") "/" (getenv "MT_TARGET") "/" (getenv "MT_RUNNAME") "/" (getenv "MT_TEST_NAME") @@ -191,36 +227,121 @@ " 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.")))))) ;; 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 ;; (define (runs:run-tests target runname test-patts user flags #!key (run-count 1)) ;; test-names (let* ((keys (keys:config-get-fields *configdat*)) (keyvals (keys:target->keyval keys target)) - (run-id (rmt:register-run keyvals runname "new" "n/a" user)) ;; test-name))) + (run-id (rmt:register-run keyvals runname "new" "n/a" user (args:get-arg "-contour"))) ;; test-name))) ;; (deferred '()) ;; delay running these since they have a waiton clause (runconfigf (conc *toppath* "/runconfigs.config")) + (dbfile (conc *toppath* "/megatest.db")) + (readonly-mode (not (file-write-access? dbfile))) (test-records (make-hash-table)) ;; 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 (task-key (conc (hash-table->alist flags) " " (get-host-name) " " (current-process-id))) - (tdbdat (tasks:open-db)) + ;; (tdbdat (tasks:open-db)) (config-reruns (let ((x (configf:lookup *configdat* "setup" "reruns"))) - (if x (string->number x) #f)))) + (if x (string->number x) #f))) + (allowed-tests #f)) + + ;; check if readonly + (when readonly-mode + (debug:print-error 0 *default-log-port* "megatest.db is readonly. Cannot proceed.") + (exit 1)) ;; per user request. If less than 100Meg space on dbdir partition, bail out with error ;; this will reduce issues in database corruption (common:check-db-dir-and-exit-if-insufficient) - + ;; override the number of reruns from the configs (if (and config-reruns (> run-count config-reruns)) (set! run-count config-reruns)) @@ -229,12 +350,12 @@ (let ((sighand (lambda (signum) ;; (signal-mask! signum) ;; to mask or not? seems to cause issues in exiting (set! *time-to-exit* #t) (print "Received signal " signum ", cleaning up before exit. Please wait...") (let ((th1 (make-thread (lambda () - (let ((tdbdat (tasks:open-db))) - (rmt:tasks-set-state-given-param-key task-key "killed")) + ;; (let ((tdbdat (tasks:open-db))) + (rmt:tasks-set-state-given-param-key task-key "killed") ;; ) (print "Killed by signal " signum ". Exiting") (thread-sleep! 3) (exit)))) (th2 (make-thread (lambda () (thread-sleep! 5) @@ -244,28 +365,48 @@ (thread-start! th1) (thread-join! th2))))) (set-signal-handler! signal/int sighand) (set-signal-handler! signal/term sighand)) + ;; 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 ;; register this run in monitor.db (rmt:tasks-add "run-tests" user target runname test-patts task-key) ;; params) (rmt:tasks-set-state-given-param-key task-key "running") ;; Now generate all the tests lists (set! all-tests-registry (tests:get-all)) ;; hash of testname => path-to-test (set! all-test-names (hash-table-keys all-tests-registry)) - (set! test-names (tests:filter-test-names all-test-names test-patts)) + ;; filter first for allowed-tests (from -tagexpr) then for test-patts. + (set! test-names (tests:filter-test-names + (if allowed-tests + (tests:filter-test-names all-test-names allowed-tests) + all-test-names) + test-patts)) ;; I think seeding required-tests with all test-names makes sense but lack analysis to back that up. ;; NEW STRATEGY HERE: ;; 1. fill required tests with test-patts @@ -300,17 +441,26 @@ ;; ;; (rmt:general-call 'delete-tests-in-state run-id "NOT_STARTED") ;; Now convert anything in allow-auto-rerun to NOT_STARTED ;; - (for-each (lambda (state) - (rmt:set-tests-state-status run-id test-names state #f "NOT_STARTED" state)) - (string-split (or (configf:lookup *configdat* "setup" "allow-auto-rerun") ""))))) + (for-each + (lambda (state-status) + (let* ((ss-lst (string-split-fields "/" state-status #:infix)) + (state (if (> (length ss-lst) 0)(car ss-lst) #f)) + (status (if (> (length ss-lst) 1)(cadr ss-lst) #f))) + (rmt:set-tests-state-status run-id test-names state status "NOT_STARTED" status))) + ;; list of state/status pairs separated by spaces + (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!? @@ -403,21 +553,17 @@ (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 () ;; (rmt:find-and-mark-incomplete-all-runs))))) CAN'T INTERRUPT IT ... (let ((run-ids (rmt:get-all-run-ids))) (for-each (lambda (run-id) @@ -477,12 +623,21 @@ (cdr reg) (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 + (define runs:nothing-left-in-queue-count 0) +;; BB: for future reference - suspect target vars are not expanded to env vars at this point (item expansion using [items]\nwhatever [system echo $TARGETVAR] doesnt work right whereas [system echo #{targetvar}] does.. Tal and Randy have tix on this. on first pass, var not set, on second pass, ok. (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 @@ -518,14 +673,11 @@ (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 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. @@ -594,14 +746,12 @@ (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 (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) (null? prereq-fails) (null? non-completed)) @@ -616,14 +766,12 @@ (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 (or (not (null? fails)) (not (null? prereq-fails))) (member 'normal testmode)) @@ -636,27 +784,21 @@ (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")))) (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)) (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 the it's all over. + ((null? runnables) #f) ;; if we get here and non-completed is null then it is all over. (else (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) '() @@ -724,12 +866,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)) @@ -755,14 +898,11 @@ ((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)) @@ -783,11 +923,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)) @@ -821,29 +961,30 @@ ;; This is the final stage, everything is in place so launch the test ;; ((and have-resources (or (null? prereqs-not-met) (and (member 'toplevel testmode) ;; 'toplevel) - (null? non-completed)))) + (null? non-completed) + (not (member 'exclusive testmode))))) ;; (hash-table-delete! *max-tries-hash* (db:test-make-full-name test-name item-path)) ;; 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 @@ -875,25 +1016,18 @@ (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) (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? - )) + (runs:loop-values tal reg reglen regfull reruns)) (let ((nth-try (hash-table-ref/default test-registry hed 0))) (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)) + (runs:loop-values tal reg reglen regfull reruns)) ((or (not nth-try) (and (number? nth-try) (< nth-try 10))) (hash-table-set! test-registry hed (if (number? nth-try) (+ nth-try 1) @@ -900,17 +1034,11 @@ 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)) + (runs:loop-values newtal reg reglen regfull reruns)) ((symbol? nth-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)) @@ -917,14 +1045,11 @@ (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)))) + (runs:loop-values newtal reg reglen regfull)))) (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) @@ -934,17 +1059,14 @@ (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))) + (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 - (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))))))))) + (runs:loop-values newtal reg reglen regfull reruns))))))))) ;; scan a list of tests looking to see if any are potentially runnable ;; (define (runs:runable-tests tests) (filter (lambda (t) @@ -1043,25 +1165,22 @@ ;; 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)) + (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)) + (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)) + ;; (tdbdat (tasks:open-db)) (runsdat (make-runs:dat ;; hed: hed ;; tal: tal ;; reg: reg ;; reruns: reruns @@ -1151,14 +1270,19 @@ newtal: newtal itemmaps: itemmaps ;; prereqs-not-met: prereqs-not-met ))) (runs:dat-regfull-set! runsdat regfull) - ;; every couple minutes verify the server is there for this run - (if (and (common:low-noise-print 60 "try start server" run-id) - (tasks:need-server run-id)) - (tasks:start-and-wait-for-server tdbdat run-id 10)) ;; NOTE: delay and wait is done under the hood + + ;; -- 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 (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))) (if (> (current-seconds)(+ last-time-some-running (or (configf:lookup *configdat* "setup" "give-up-waiting") 36000))) @@ -1286,11 +1410,11 @@ (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)) + ((or (procedure? items)(eq? items 'have-procedure)) ;; BB - target vars are env vars here? to allow expansion of [items]\nsomething [system echo $SOMETARGVAR], which is wonky (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))) (if loop-list @@ -1324,11 +1448,11 @@ ;; 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 (let wait-loop ((num-running (rmt:get-count-tests-running-for-run-id run-id)) (prev-num-running 0)) - ;; (BB> "num-running=" num-running ", prev-num-running=" prev-num-running) + ;; (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")) (> num-running 0)) (begin ;; Here we mark any old defunct tests as incomplete. Do this every fifteen minutes @@ -1343,10 +1467,11 @@ (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)) @@ -1381,11 +1506,12 @@ (filter (lambda (t) (or (not (vector? t)) (and (equal? "NOT_STARTED" (db:test-get-state t)) (member (db:test-get-status t) - '("n/a" "KEEP_TRYING"))))) + '("n/a" "KEEP_TRYING"))) + (and (equal? "RUNNING" (db:test-get-state t))))) ;; account for a test that is running prereqs-not-met)) (define (runs:pretty-string lst) (map (lambda (t) (if (not (vector? t)) @@ -1466,11 +1592,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") @@ -1534,13 +1660,12 @@ (let ((running-tests (rmt:get-tests-for-runs-mindata #f full-test-name '("RUNNING" "REMOTEHOSTSTART" "LAUNCHED") '() #f))) (if (not (null? running-tests)) ;; have to skip (set! skip-test "Skipping due to previous tests running")))) ((and skip-check (configf:lookup test-conf "skip" "fileexists")) - (if (file-exists? (configf:lookup test-conf "skip" "fileexists")) + (if (common:file-exists? (configf:lookup test-conf "skip" "fileexists")) (set! skip-test (conc "Skipping due to existance of file " (configf:lookup test-conf "skip" "fileexists"))))) - ((and skip-check (configf:lookup test-conf "skip" "rundelay")) ;; run-ids = #f means *all* runs (let* ((numseconds (common:hms-string->seconds (configf:lookup test-conf "skip" "rundelay"))) (running-tests (rmt:get-tests-for-runs-mindata #f full-test-name '("RUNNING" "REMOTEHOSTSTART" "LAUNCHED") '() #f)) @@ -1626,23 +1751,33 @@ ;; '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)) + ;; (tdbdat (tasks:open-db)) (keys (rmt:get-keys)) (rundat (mt:get-runs-by-patt keys runnamepatt target)) (header (vector-ref rundat 0)) (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") (exit))) @@ -1677,11 +1812,11 @@ (tasks:kill-runner target run-name testpatt) ;; (debug:print 0 *default-log-port* "not attempting to kill any run launcher processes as testpatt is " testpatt)) (debug:print 1 *default-log-port* "Removing tests for run: " runkey " " (db:get-value-by-header run header "runname"))) ((set-state-status) - (if (tasks:need-server run-id)(tasks:start-and-wait-for-server tdbdat run-id 10)) + ;; (if (tasks:need-server run-id)(tasks:start-and-wait-for-server tdbdat run-id 10)) (debug:print 1 *default-log-port* "Modifying state and staus for tests for run: " runkey " " (db:get-value-by-header run header "runname"))) ((print-run) (debug:print 1 *default-log-port* "Printing info for run " runkey ", run=" run ", tests=" tests ", header=" header) action) ((run-wait) @@ -1788,29 +1923,32 @@ ((archive) (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)))))) ;; 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)))) @@ -1821,25 +1959,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"))) @@ -1861,14 +2015,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 ;;====================================================================== @@ -1888,14 +2044,17 @@ (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))) + + (set! keys (keys:config-get-fields *configdat*)) ;; have enough to process -target or -reqtarg here (if (args:get-arg "-reqtarg") (let* ((runconfigf (conc *toppath* "/runconfigs.config")) ;; DO NOT EVALUATE ALL (runconfig (read-config runconfigf #f #t environ-patt: #f))) @@ -1968,11 +2127,11 @@ (let* ((tagdata (rmt:get-tests-tags)) (res '())) ;; list of tests that match one or more tags (for-each (lambda (tag) (if (patt-list-match tag tagpatt) - (set! res (append (hash-table-ref tagdata tag))))) + (set! res (append (hash-table-ref tagdata tag) res)))) (hash-table-keys tagdata)) res)) ;; Update test_meta for all tests @@ -1989,11 +2148,11 @@ ;; (define (runs:rollup-run keys runname user keyvals) (debug:print 4 *default-log-port* "runs:rollup-run, keys: " keys " -runname " runname " user: " user) (let* ((db #f) ;; register run operates on the main db - (new-run-id (rmt:register-run keyvals runname "new" "n/a" user)) + (new-run-id (rmt:register-run keyvals runname "new" "n/a" user (args:get-arg "-contour"))) (prev-tests (rmt:get-matching-previous-test-run-records new-run-id "%" "%")) (curr-tests (mt:get-tests-for-run new-run-id "%/%" '() '())) (curr-tests-hash (make-hash-table))) (rmt:update-run-event_time new-run-id) ;; index the already saved tests by testname and itemdat in curr-tests-hash @@ -2041,5 +2200,28 @@ (db:test-get-id testdat)))) )) prev-tests))) +;; clean cache files +(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 (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.") + (begin + (debug:print-info 0 *default-log-port* "Removing cached files:\n " (string-intersperse files "\n ")) + (for-each + (lambda (f) + (handle-exceptions + exn + (debug:print 0 *default-log-port* "WARNING: Failed to remove file " f) + (delete-file f))) + files)))) + (debug:print-error 0 *default-log-port* "-clean-cache requires -runname.")) + (debug:print-error 0 *default-log-port* "-clean-cache requires -target or -reqtarg"))) 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 @@ -18,11 +18,11 @@ (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 launch)) (declare (uses daemon)) @@ -112,11 +112,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" "maxhomehostload" 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 +130,11 @@ (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 + (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))) @@ -140,26 +141,29 @@ ;; given a path to a server log return: host port startseconds ;; (define (server:logf-get-start-info logf) (let ((rx (regexp "^SERVER STARTED: (\\S+):(\\d+) AT ([\\d\\.]+)"))) ;; SERVER STARTED: host:port AT timesecs - (with-input-from-file - logf - (lambda () - (let loop ((inl (read-line)) - (lnum 0)) - (if (not (eof-object? inl)) - (let ((mlst (string-match rx inl))) - (if (not mlst) - (if (< lnum 500) ;; give up if more than 500 lines of server log read - (loop (read-line)(+ lnum 1)) - (list #f #f #f)) - (let ((dat (cdr mlst))) - (list (car dat) ;; host - (string->number (cadr dat)) ;; port - (string->number (caddr dat)))))) - (list #f #f #f))))))) + (handle-exceptions + exn + (list #f #f #f) ;; no idea what went wrong, call it a bad server + (with-input-from-file + logf + (lambda () + (let loop ((inl (read-line)) + (lnum 0)) + (if (not (eof-object? inl)) + (let ((mlst (string-match rx inl))) + (if (not mlst) + (if (< lnum 500) ;; give up if more than 500 lines of server log read + (loop (read-line)(+ lnum 1)) + (list #f #f #f)) + (let ((dat (cdr mlst))) + (list (car dat) ;; host + (string->number (cadr dat)) ;; port + (string->number (caddr dat)))))) + (list #f #f #f)))))))) ;; get a list of servers with all relevant data ;; ( mod-time host port start-time pid ) ;; (define (server:get-list areapath #!key (limit #f)) @@ -167,32 +171,35 @@ (day-seconds (* 24 60 60))) ;; if the directory exists continue to get the list ;; otherwise attempt to create the logs dir and then ;; continue (if (if (directory-exists? (conc areapath "/logs")) - #t + '() (if (file-write-access? areapath) (begin (condition-case (create-directory (conc areapath "/logs") #t) (exn (i/o file)(debug:print 0 *default-log-port* "ERROR: Cannot create directory at " (conc areapath "/logs"))) (exn ()(debug:print 0 *default-log-port* "ERROR: Unknown error attemtping to get server list."))) (directory-exists? (conc areapath "/logs"))) - #f)) + '())) (let* ((server-logs (glob (conc areapath "/logs/server-*.log"))) (num-serv-logs (length server-logs))) (if (null? server-logs) '() (let loop ((hed (car server-logs)) (tal (cdr server-logs)) (res '())) - (let* ((mod-time (file-modification-time hed)) + (let* ((mod-time (handle-exceptions + exn + (current-seconds) ;; 0 + (file-modification-time hed))) ;; default to *very* old so log gets ignored if deleted (down-time (- (current-seconds) mod-time)) (serv-dat (if (or (< num-serv-logs 10) - (< down-time day-seconds)) - (server:logf-get-start-info hed) - '())) ;; don't waste time processing server files not touched in the past day if there are more than ten servers to look at + (< down-time 900)) ;; day-seconds)) + (server:logf-get-start-info hed) + '())) ;; don't waste time processing server files not touched in the 15 minutes if there are more than ten servers to look at (serv-rec (cons mod-time serv-dat)) (fmatch (string-match fname-rx hed)) (pid (if fmatch (string->number (list-ref fmatch 2)) #f)) (new-res (if (null? serv-dat) res @@ -200,11 +207,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 ;; @@ -212,35 +233,52 @@ ;; ;; sort by start-time descending. I.e. get the oldest first. Young servers will thus drop off ;; and servers should stick around for about two hours or so. ;; (define (server:get-best srvlst) - (let ((now (current-seconds))) - (sort - (filter (lambda (rec) - (let ((start-time (list-ref rec 3)) - (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) - (+ (- (string->number (or (configf:lookup *configdat* "server" "runtime") "3600")) - 180) - (random 360))) ;; under one hour running time +/- 180 - ))) - srvlst) - (lambda (a b) - (< (list-ref a 3) - (list-ref b 3)))))) + (let* ((nums (server:get-num-servers)) + (now (current-seconds)) + (slst (sort + (filter (lambda (rec) + (if (and (list? rec) + (> (length rec) 2)) + (let ((start-time (list-ref rec 3)) + (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) + (+ (- (string->number (or (configf:lookup *configdat* "server" "runtime") "3600")) + 180) + (random 360))) ;; under one hour running time +/- 180 + )) + #f)) + srvlst) + (lambda (a b) + (< (list-ref a 3) + (list-ref b 3)))))) + (if (> (length slst) nums) + (take slst nums) + slst))) (define (server:get-first-best areapath) (let ((srvrs (server:get-best (server:get-list areapath)))) (if (and srvrs (not (null? srvrs))) (car srvrs) #f))) + +(define (server:get-rand-best areapath) + (let ((srvrs (server:get-best (server:get-list areapath)))) + (if (and (list? srvrs) + (not (null? srvrs))) + (let* ((len (length srvrs)) + (idx (random len))) + (list-ref srvrs idx)) + #f))) + (define (server:record->url servr) (match-let (((mod-time host port start-time pid) servr)) (if (and host port) @@ -254,51 +292,62 @@ *my-client-signature*))) ;; kind start up of servers, wait 40 seconds before allowing another server for a given ;; run-id to be launched (define (server:kind-run areapath) - (let* ((last-run-dat (hash-table-ref/default *server-kind-run* areapath '(0 0))) ;; callnum, whenrun - (call-num (car last-run-dat)) - (when-run (cadr last-run-dat)) - (run-delay (+ (case call-num - ((0) 0) - ((1) 20) - ((2) 300) - (else 600)) - (random 5)))) ;; add a small random number just in case a lot of jobs hit the work hosts simultaneously - (if (> (- (current-seconds) when-run) run-delay) - (server:run areapath)) - (hash-table-set! *server-kind-run* areapath (list (+ call-num 1)(current-seconds))))) + (if (not (server:check-if-running areapath)) ;; why try if there is already a server running? + (let* ((last-run-dat (hash-table-ref/default *server-kind-run* areapath '(0 0))) ;; callnum, whenrun + (call-num (car last-run-dat)) + (when-run (cadr last-run-dat)) + (run-delay (+ (case call-num + ((0) 0) + ((1) 20) + ((2) 300) + (else 600)) + (random 5))) ;; add a small random number just in case a lot of jobs hit the work hosts simultaneously + (lock-file (conc areapath "/logs/server-start.lock"))) + (if (> (- (current-seconds) when-run) run-delay) + (begin + (common:simple-file-lock-and-wait lock-file expire-time: 15) + (server:run areapath) + (thread-sleep! 5) ;; don't release the lock for at least a few seconds + (common:simple-file-release-lock lock-file))) + (hash-table-set! *server-kind-run* areapath (list (+ call-num 1)(current-seconds)))))) (define (server:start-and-wait areapath #!key (timeout 60)) (let ((give-up-time (+ (current-seconds) timeout))) - (let loop ((server-url (server:check-if-running areapath))) + (let loop ((server-url (server:check-if-running areapath)) + (try-num 0)) (if (or server-url (> (current-seconds) give-up-time)) ;; server-url will be #f if no server available. server-url (let ((num-ok (length (server:get-best (server:get-list areapath))))) - (if (< num-ok 1) ;; if there are no decent candidates for servers then try starting a new one + (if (and (> try-num 0) ;; first time through simply wait a little while then try again + (< num-ok 1)) ;; if there are no decent candidates for servers then try starting a new one (server:kind-run areapath)) (thread-sleep! 5) - (loop (server:check-if-running areapath))))))) + (loop (server:check-if-running areapath) + (+ try-num 1))))))) (define server:try-running server:run) ;; there is no more per-run servers ;; REMOVE ME. BUG. -(define (server:dotserver-age-seconds areapath) - (let ((server-file (conc areapath "/.server"))) - (begin - (handle-exceptions - exn - #f - (- (current-seconds) - (file-modification-time server-file)))))) - +(define (server:get-num-servers #!key (numservers 2)) + (let ((ns (string->number + (or (configf:lookup *configdat* "server" "numservers") "notanumber")))) + (or ns numservers))) + ;; no longer care if multiple servers are started by accident. older servers will drop off in time. ;; -(define (server:check-if-running areapath) - (let* ((servers (server:get-best (server:get-list areapath)))) - (if (null? servers) +(define (server:check-if-running areapath) ;; #!key (numservers "2")) + (let* ((ns (server:get-num-servers)) + (servers (server:get-best (server:get-list areapath)))) + ;; (print "servers: " servers " ns: " ns) + (if (or (and servers + (null? servers)) + (not servers) + (and (list? servers) + (< (length servers) (random ns)))) ;; somewhere between 0 and numservers #f (let loop ((hed (car servers)) (tal (cdr servers))) (let ((res (server:check-server hed))) (if res @@ -381,22 +430,156 @@ ((NOREPLY) #f) ((LOGIN_OK) #t) (else #f)) (loop (read-line) inl)))))) +;; NOT USED (well, ok, reference in rpc-transport but otherwise not used). +;; (define (server:login toppath) (lambda (toppath) (set! *db-last-access* (current-seconds)) ;; might not be needed. (if (equal? *toppath* toppath) #t #f))) -(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 1) ;; default to one minute - ;; (* 60 60 25) ;; default to 25 hours - ))) + (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))) + +;; 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,13 @@ +(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) + + Index: tasks.scm ================================================================== --- tasks.scm +++ tasks.scm @@ -14,12 +14,16 @@ (declare (unit tasks)) (declare (uses db)) (declare (uses rmt)) (declare (uses common)) +(declare (uses pgdb)) + +;; (import pgdb) ;; pgdb is a module (include "task_records.scm") +(include "db_records.scm") ;;====================================================================== ;; Tasks db ;;====================================================================== @@ -32,34 +36,35 @@ (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))) #t)))))) (define (tasks:get-task-db-path) (let ((dbdir (or (configf:lookup *configdat* "setup" "monitordir") (configf:lookup *configdat* "setup" "dbdir") - (conc (configf:lookup *configdat* "setup" "linktree") "/.db")))) + (conc (common:get-linktree) "/.db")))) (handle-exceptions exn (begin (debug:print-error 0 *default-log-port* "Couldn't create path to " dbdir) (exit 1)) @@ -82,21 +87,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)))) - (let* ((dbpath (tasks:get-task-db-path)) + (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)) @@ -178,15 +183,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 ;;====================================================================== @@ -574,6 +591,149 @@ ;; keys ;; keyvals ;; (tasks:task-get-name task) ;; (tasks:task-get-owner task)) ;; (tasks:set-state mdb (tasks:task-get-id task) "waiting"))) + +;;====================================================================== +;; S Y N C T O P O S T G R E S Q L +;;====================================================================== + +;; In the spirit of "dump your junk in the tasks module" I'll put the +;; sync to postgres here for now. + +;; attempt to automatically set up an area. call only if get area by path +;; returns naught of interest +;; +(define (tasks:set-area dbh configdat #!key (toppath #f)) ;; could I safely put *toppath* in for the default for toppath? when would it be evaluated? + (let loop ((area-name (or (configf:lookup configdat "setup" "area-name") + (common:get-area-name))) + (modifier 'none)) + (let ((success (handle-exceptions + exn + (begin + (debug:print 0 *default-log-port* "ERROR: cannot create area entry, " ((condition-property-accessor 'exn 'message) exn)) + #f) ;; FIXME: I don't care for now but I should look at *why* there was an exception + (pgdb:add-area dbh area-name (or toppath *toppath*))))) + (or success + (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 + +;; gets mtpg-run-id and syncs the record if different +;; +(define (tasks:run-id->mtpg-run-id dbh cached-info run-id) + (let* ((runs-ht (hash-table-ref cached-info 'runs)) + (runinf (hash-table-ref/default runs-ht run-id #f))) + (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 ")) + (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"))) + (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)) + + + + ;; (area-id (db:get-value-by-header row header "area_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) + new-run-id) + (if (handle-exceptions + exn + (begin (print-call-chain) #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)))))) + +(define (tasks:sync-tests-data dbh cached-info test-ids) + (let ((test-ht (hash-table-ref cached-info 'tests))) + (for-each + (lambda (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)) + (state (db:test-get-state test-info)) + (status (db:test-get-status test-info)) + (host (db:test-get-host test-info)) + (cpuload (db:test-get-cpuload test-info)) + (diskfree (db:test-get-diskfree test-info)) + (uname (db:test-get-uname test-info)) + (run-dir (db:test-get-rundir test-info)) + (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))) + ;; "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 + (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) + (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)) + )) + test-ids))) + +;; get runs changed since last sync +;; (define (tasks:sync-test-data dbh cached-info area-info) +;; (let* (( + +(define (tasks:sync-to-postgres configdat dest) + (let* ((dbh (pgdb:open configdat dbname: dest)) + (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)) + (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) + (if (not (null? test-ids)) + (begin + (print "Syncing " (length test-ids) " changed tests") + (tasks:sync-tests-data dbh cached-info test-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 @@ -50,11 +50,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)) Index: tests.scm ================================================================== --- tests.scm +++ tests.scm @@ -41,11 +41,16 @@ (define (tests:get-all) (let* ((test-search-path (tests:get-tests-search-path *configdat*))) (tests:get-valid-tests (make-hash-table) test-search-path))) (define (tests:get-tests-search-path cfgdat) - (let ((paths (map cadr (configf:get-section cfgdat "tests-paths")))) + (let ((paths (let ((section (if cfgdat + (configf:get-section cfgdat "tests-paths") + #f))) + (if section + (map cadr section) + '())))) (filter (lambda (d) (if (directory-exists? d) d (begin (if (common:low-noise-print 60 "tests:get-tests-search-path" d) @@ -56,16 +61,16 @@ (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)))))) @@ -300,11 +305,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) @@ -317,11 +322,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)) @@ -415,19 +420,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 "," @@ -434,11 +439,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) ;;;;;) @@ -486,11 +493,14 @@ (change-directory orig-dir) ;; NB// tests:test-set-toplog! is remote internal... (tests:test-set-toplog! run-id test-name outputfilename)) ;; didn't get the lock, check to see if current update started later than this ;; update, if so we can exit without doing any work - (if (> my-start-time (file-modification-time lockf)) + (if (> my-start-time (handle-exceptions + exn + 0 + (file-modification-time lockf))) ;; we started since current re-gen in flight, delay a little and try again (begin (debug:print-info 1 *default-log-port* "Waiting to update " outputfilename ", another test currently updating it") (thread-sleep! (+ 5 (random 5))) ;; delay between 5 and 10 seconds (loop (common:simple-file-lock lockf)))))))))) @@ -831,11 +841,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") @@ -870,11 +880,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) @@ -898,21 +908,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))))) )))))) @@ -939,19 +949,21 @@ (for-each (lambda (step) (debug:print 6 *default-log-port* "step=" step) (let ((record (hash-table-ref/default res - (tdb:step-get-stepname step) - ;; stepname start end status Duration Logfile Comment - (vector (tdb:step-get-stepname step) "" "" "" "" "" "")))) + (tdb:step-get-stepname step) + ;; 0 1 2 3 4 5 6 7 + ;; stepname start end status Duration Logfile Comment first-id + (vector (tdb:step-get-stepname step) "" "" "" "" "" "" #f)))) (debug:print 6 *default-log-port* "record(before) = " record "\nid: " (tdb:step-get-id step) "\nstepname: " (tdb:step-get-stepname step) "\nstate: " (tdb:step-get-state step) "\nstatus: " (tdb:step-get-status step) "\ntime: " (tdb:step-get-event_time step)) + (if (not (vector-ref record 7))(vector-set! record 7 (tdb:step-get-id step))) ;; do not clobber the id if previously set (case (string->symbol (tdb:step-get-state step)) ((start)(vector-set! record 1 (tdb:step-get-event_time step)) (vector-set! record 3 (if (equal? (vector-ref record 3) "") (tdb:step-get-status step))) (if (> (string-length (tdb:step-get-logfile step)) @@ -995,88 +1007,97 @@ res)) ;; ;; (define (tests:get-compressed-steps run-id test-id) - (let* ((steps-data (rmt:get-steps-for-test run-id test-id)) - (comprsteps (tests:process-steps-table steps-data))) ;; (open-run-close db:get-steps-table #f test-id work-area: work-area))) + (let* ((steps-data (rmt:get-steps-for-test run-id test-id)) ;; 0 1 2 3 4 5 6 7 + (comprsteps (tests:process-steps-table steps-data))) ;; # (map (lambda (x) ;; take advantage of the \n on time->string - (vector - (vector-ref x 0) + (vector ;; we are constructing basically the original vector but collapsing start end records + (vector-ref x 0) ;; id 0 (let ((s (vector-ref x 1))) - (if (number? s)(seconds->time-string s) s)) + (if (number? s)(seconds->time-string s) s)) ;; starttime 1 (let ((s (vector-ref x 2))) - (if (number? s)(seconds->time-string s) s)) - (vector-ref x 3) ;; status - (vector-ref x 4) - (vector-ref x 5) ;; time delta - (vector-ref x 6))) + (if (number? s)(seconds->time-string s) s)) ;; endtime 2 + (vector-ref x 3) ;; status 3 + (vector-ref x 4) ;; duration 4 + (vector-ref x 5) ;; logfile 5 + (vector-ref x 6) ;; comment 6 + (vector-ref x 7))) ;; id 7 (sort (hash-table-values comprsteps) (lambda (a b) (let ((time-a (vector-ref a 1)) - (time-b (vector-ref b 1))) + (time-b (vector-ref b 1)) + (id-a (vector-ref a 7)) + (id-b (vector-ref b 7))) (if (and (number? time-a)(number? time-b)) (if (< time-a time-b) #t (if (eq? time-a time-b) - (stringwork-week/day-time - (db:test-get-event_time test-dat))) - (s:td "Duration") (s:td (seconds->hr-min-sec (db:test-get-run_duration test-dat))))) - (s:h3 "Log files") - (s:table - 'cellspacing "0" 'border "1" - (s:tr (s:td "Final log")(s:td (s:a 'href logf logf)))) - (s:table - 'cellspacing "0" 'border "1" - (s:tr (s:td "Step Name")(s:td "Start")(s:td "End")(s:td "Status")(s:td "Duration")(s:td "Log File")) - (map (lambda (step-dat) - (s:tr (s:td (tdb:steps-table-get-stepname step-dat)) - (s:td (tdb:steps-table-get-start step-dat)) - (s:td (tdb:steps-table-get-end step-dat)) - (s:td (tdb:steps-table-get-status step-dat)) - (s:td (tdb:steps-table-get-runtime step-dat)) - (s:td (let ((step-log (tdb:steps-table-get-log-file step-dat))) - (s:a 'href step-log step-log))))) - steps-dat)) - ))) - (close-output-port oup))) + (out-dir (db:test-get-rundir test-dat)) + (out-file (conc out-dir "/test-summary.html"))) + ;; first verify we are able to write the output file + (if (not (file-write-access? out-dir)) + (debug:print 0 *default-log-port* "ERROR: cannot write test-summary.html to " out-dir) + (let* (;; (steps-dat (rmt:get-steps-for-test run-id test-id)) + (test-name (db:test-get-testname test-dat)) + (item-path (db:test-get-item-path test-dat)) + (full-name (db:test-make-full-name test-name item-path)) + (oup (open-output-file out-file)) + (status (db:test-get-status test-dat)) + (color (common:get-color-from-status status)) + (logf (db:test-get-final_logf test-dat)) + (steps-dat (tests:get-compressed-steps run-id test-id))) + ;; (dcommon:get-compressed-steps #f 1 30045) + ;; (#("wasting_time" "23:36:13" "23:36:21" "0" "8.0s" "wasting_time.log")) + + (s:output-new + oup + (s:html + (s:title "Summary for " full-name) + (s:body + (s:h2 "Summary for " full-name) + (s:table 'cellspacing "0" 'border "1" + (s:tr (s:td "run id") (s:td (db:test-get-run_id test-dat)) + (s:td "test id") (s:td (db:test-get-id test-dat))) + (s:tr (s:td "testname") (s:td test-name) + (s:td "itempath") (s:td item-path)) + (s:tr (s:td "state") (s:td (db:test-get-state test-dat)) + (s:td "status") (s:td (s:a 'href logf (s:font 'color color status)))) + (s:tr (s:td "TestDate") (s:td (seconds->work-week/day-time + (db:test-get-event_time test-dat))) + (s:td "Duration") (s:td (seconds->hr-min-sec (db:test-get-run_duration test-dat))))) + (s:h3 "Log files") + (s:table + 'cellspacing "0" 'border "1" + (s:tr (s:td "Final log")(s:td (s:a 'href logf logf)))) + (s:table + 'cellspacing "0" 'border "1" + (s:tr (s:td "Step Name")(s:td "Start")(s:td "End")(s:td "Status")(s:td "Duration")(s:td "Log File")) + (map (lambda (step-dat) + (s:tr (s:td (tdb:steps-table-get-stepname step-dat)) + (s:td (tdb:steps-table-get-start step-dat)) + (s:td (tdb:steps-table-get-end step-dat)) + (s:td (tdb:steps-table-get-status step-dat)) + (s:td (tdb:steps-table-get-runtime step-dat)) + (s:td (let ((step-log (tdb:steps-table-get-log-file step-dat))) + (s:a 'href step-log step-log))))) + steps-dat)) + ))) + (close-output-port oup))))) ;; MUST BE CALLED local! ;; (define (tests:test-get-paths-matching keynames target fnamepatt #!key (res '())) @@ -1110,11 +1131,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 "/"))) @@ -1127,29 +1148,32 @@ (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)) - (let* ((cache-path (tests:get-test-path-from-environment)) +(define (tests:get-testconfig test-name item-path test-registry system-allowed #!key (force-create #f)(allow-write-cache #t)) + (let* ((use-cache (common:use-cache?)) + (cache-path (tests:get-test-path-from-environment)) (cache-file (and cache-path (conc cache-path "/.testconfig"))) (cache-exists (and cache-file (not force-create) ;; if force-create then pretend there is no cache to read - (file-exists? cache-file))) + (common:file-exists? cache-file))) (cached-dat (if (and (not force-create) - cache-exists) + cache-exists + use-cache) (handle-exceptions exn #f ;; any issues, just give up with the cached version and re-read (configf:read-alist cache-file)) #f)) @@ -1166,11 +1190,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)) @@ -1177,14 +1201,16 @@ #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) - (configf:write-alist tcfg tpath))) + (if (not (common:in-running-test?)) + (configf:write-alist tcfg tpath)))) tcfg)))))) ;; sort tests by priority and waiton ;; Move test specific stuff to a test unit FIXME one of these days (define (tests:sort-by-priority-and-waiton test-records) @@ -1334,11 +1360,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) @@ -1537,11 +1563,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 @@ -19,13 +19,15 @@ # The NEWTARGET causes some tests to fail. Do not use until this is fixed. NEWTARGET = "$(OS)/$(FS)/$(VER)" TARGET = "ubuntu/nfs/none" -all : build unit test1 test2 test3 test4 test5 test6 test7 test8 test9 +all : build unit test4 +# test1 test2 test3 test4 test5 test6 test7 test8 test9 -unit : basicserver.log runs.log misc.log tests.log +unit : all-rmt.log +# basicserver.log runs.log misc.log tests.log rel : cd release;dashboard -rows 25 & ## basicserver.log : unittests/basicserver.scm Index: tests/fdktestqa/testqa/megatest.config ================================================================== --- tests/fdktestqa/testqa/megatest.config +++ tests/fdktestqa/testqa/megatest.config @@ -1,9 +1,14 @@ [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 +launch-delay 0.1 + +[server] +# runtime 180 +# timeout is in hours, this is how long the server will stay alive when not being used. +timeout 0.1 # All these are overridden in ../fdk.config # [jobtools] # launcher nbfake # launcher bsub -q priority -o $MT_TEST_RUN_DIR/openlava.log Index: tests/fdktestqa/testqa/runsuite.sh ================================================================== --- tests/fdktestqa/testqa/runsuite.sh +++ tests/fdktestqa/testqa/runsuite.sh @@ -1,18 +1,17 @@ #!/bin/bash -(cd ../../..;make && make install) || exit 1 -export PATH=$PWD/../../../bin:$PATH +# (cd ../../..;make && make install) || exit 1 +# export PATH=$PWD/../../../bin:$PATH for i in a b c d e f;do # g h i j k l m n o p q r s t u v w x y z;do - megatest -runtests % -target a/b :runname $i & + viewscreen megatest -run -testpatt % -target a/b -runname w$(date +%U.%u.%H)$i done echo "" > num-running.log while true; do - foo=`megatest -list-runs % | grep RUNNING | wc -l` + foo=$(megatest -list-runs % | grep RUNNING | wc -l) echo "Num running at `date` $foo" echo "$foo at `date`" >> num-running.log - # to make the test go at a reasonable clip only gather this info ever minute - sleep 1m + sleep 10 done Index: tests/fdktestqa/testqa/tests/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 @@ -99,12 +99,12 @@ # htmlviewercmd firefox -new-window htmlviewercmd arora # -runtests automatically deletes the records for tests with the listed states on starting up a run allowing them to re-run # (nb// this is in addition to NOT_STARTED which is automatically re-run) -# -allow-auto-rerun INCOMPLETE ZERO_ITEMS +# format is STATE/STATUS +allow-auto-rerun /INCOMPLETE /ZERO_ITEMS # could add: STUCK STUCK/DEAD UNKNOWN KILLED KILLREQ PREQ_DISCARD [validvalues] state start end 0 1 - 2 status pass fail n/a 0 1 running - 2 @@ -238,10 +238,11 @@ # Archives will be organised under these paths like this: # / # Within the archive the data is structured like this: # /// disk0 /tmp/#{getenv USER}/adisk1 +disk1 /mfs/tmp/archive # Uncomment these to emulate a job queue with a long time (look in bin/sleeprunner for the time) [jobtools] launcher #{scheme (case (string->symbol (conc (getenv "datapath"))) \ ((none) "nbfake") \ @@ -251,10 +252,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,9 +1,10 @@ [default] SOMEVAR This should show up in SOMEVAR3 VARNOVAL -VARNOVAL_WITHSPACE +VARNOVAL_WITHSPACE +QUICK % # 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] @@ -43,6 +44,16 @@ [ubuntu/nfs/sleep60] SLEEPRUNNER 60 [ubuntu/nfs/sleep240] SLEEPRUNNER 240 + +[v1.63/tip/dev] +QUICKPATT %/desert,%/ae +# OTHER_PATT foo%/desert,%/ae + +# [v1.63/%/%] +# QUICKPATT %/desert,%/ae + +[nada/foo/bar] +junk foo 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/fullrun/tests/sqlitespeed/testconfig ================================================================== --- tests/fullrun/tests/sqlitespeed/testconfig +++ tests/fullrun/tests/sqlitespeed/testconfig @@ -9,5 +9,7 @@ MANYITEMS [system (env > envfile.txt;echo aa ab ac ad ae af ag ah ai)] # BORKED [test_meta] jobgroup sqlite3 +tags quick + Index: tests/fullrun/tests/test_mt_vars/testconfig ================================================================== --- tests/fullrun/tests/test_mt_vars/testconfig +++ tests/fullrun/tests/test_mt_vars/testconfig @@ -52,7 +52,7 @@ [test_meta] author matt owner bob description This test runs a single ezstep which is expected to pass, no logpro file. -tags first,single +tags quick,first,single reviewed 09/10/2011, by Matt Index: tests/rununittest.sh ================================================================== --- tests/rununittest.sh +++ tests/rununittest.sh @@ -4,11 +4,11 @@ # banner $1 # put megatest on path from correct location mtbindir=$(readlink -f ../bin) - + export PATH="${mtbindir}:$PATH" # Clean setup # dbdir=$(echo /tmp/$USER/megatest_localdb/simplerun/.[a-zA-Z]*/) Index: tests/simplerun/tests/test2/testconfig ================================================================== --- tests/simplerun/tests/test2/testconfig +++ tests/simplerun/tests/test2/testconfig @@ -15,7 +15,7 @@ # test_meta is a section for storing additional data on your test [test_meta] author matt owner matt description Yet another example test -tags tagone,tagtwo +tags tagone,tagtwo,quick reviewed never Index: tests/tests.scm ================================================================== --- tests/tests.scm +++ tests/tests.scm @@ -17,10 +17,26 @@ (import srfi-18) ;; (require-extension zmq) ;; (import zmq) (define test-work-dir (current-directory)) + +;; given list of lists +;; ( ( msg expected param1 param2 ...) +;; ( ... ) ) +;; apply test to all +;; +(define (test-batch proc pname inlst #!key (post-proc #f)) + (for-each + (lambda (spec) + (let ((msg (conc pname " " (car spec))) + (result (cadr spec)) + (params (cddr spec))) + (if post-proc + (test msg result (post-proc (apply proc params))) + (test msg result (apply proc params))))) + inlst)) ;; read in all the _record files (let ((files (glob "*_records.scm"))) (for-each (lambda (file) @@ -32,11 +48,11 @@ (fname (conc "../unittests/" unit-test-name ".scm"))) (if (file-exists? fname) (load fname) (print "ERROR: Unit test " unit-test-name " not found in unittests directory"))) - - (list "abc" "abc/%" "ab%/c%" "~abc/c%" "abc/~c%" "a,b/c,%/d" "%/,%/a" "%/,%/a" "%/,%/a" "%" "%" "%/" "%/" "%abc%") - (list "abc" "abc" "abcd" "abc" "abc" "a" "abc" "def" "ghi" "a" "a" "a" "a" "abc") - (list "" "" "cde" "cde" "cde" "" "" "a" "b" "" "b" "" "b" "abc") - (list #t #t #t #f #f #t #t #t #f #t #t #t #f #t)) +;;; huh? why is this here? +;; (list "abc" "abc/%" "ab%/c%" "~abc/c%" "abc/~c%" "a,b/c,%/d" "%/,%/a" "%/,%/a" "%/,%/a" "%" "%" "%/" "%/" "%abc%") +;; (list "abc" "abc" "abcd" "abc" "abc" "a" "abc" "def" "ghi" "a" "a" "a" "a" "abc") +;; (list "" "" "cde" "cde" "cde" "" "" "a" "b" "" "b" "" "b" "abc") +;; (list #t #t #t #f #f #t #t #t #f #t #t #t #f #t) ADDED tests/unittests/all-rmt.scm Index: tests/unittests/all-rmt.scm ================================================================== --- /dev/null +++ tests/unittests/all-rmt.scm @@ -0,0 +1,150 @@ + +;;====================================================================== +;; A L L - R M T +;;====================================================================== + +;; Run like this: +;; +;; ./rununittest.sh all-rmt 1 + +;; Definitions: +;; NTN - no test needed +;; DEP - function is deprecated, no point in testing +;; NED - function nested under others, no test needed. +;; DEF - deferred + +(print "start dir: " (current-directory)) + +(define toppath (current-directory)) +(test #f #t (string?(server:start-and-wait *toppath*))) + +(test "setup for run" #t (begin (launch:setup) + (string? (getenv "MT_RUN_AREA_HOME")))) +(test #f #t (vector? (client:setup toppath))) + +(test #f #t (vector? (rmt:get-connection-info toppath))) ;; TODO: push areapath down. +(test #f #t (string? (server:check-if-running "."))) +;; DEF (test #f #f (rmt:send-receive-no-auto-client-setup *runremote* 'get-keys #f '())) +;; DEF (rmt:kill-server run-id) +;; DEF (rmt:start-server run-id) +(test #f '(#t "successful login")(rmt:login #f)) +;; DEF (rmt:login-no-auto-client-setup connection-info) +(test #f #t (pair? (rmt:get-latest-host-load (get-host-name)))) + +;; get-latest-host-load does a lookup in the db, it won't return a useful value unless +;; a test ran recently on host +(test-batch rmt:get-latest-host-load + "rmt:get-latest-host-load" + (list (list "localhost" #t (get-host-name)) + (list "not-a-host" #t "not-a-host" )) + post-proc: pair?) + +(test #f #t (list? (rmt:get-changed-record-ids 0))) + +(test #f #f (begin (runs:update-all-test_meta #f) #f)) + +(test #f '("test1" "test2")(sort (alist-ref "tagtwo" (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)) +(test #f "" (rmt:get-target 1)) +(test #f #t (rmt:register-test 1 "foo" "")) +(test #f 1 (rmt:get-test-id 1 "foo" "")) +(test #f "foo" (vector-ref (rmt:get-test-info-by-id 1 1) 2)) +(test #f "/tmp/badname" (rmt:test-get-rundir-from-test-id 1 1)) +(test #f '(1) (db:set-tests-state-status *db* 1 '("foo") "COMPLETED" "PASS" "NOT_STARTED" "PASS")) +(test #f '(1) (rmt:set-tests-state-status 1 '("foo") "COMPLETED" "PASS" "NOT_STARTED" "PASS")) +(test #f #t (mt:test-set-state-status-by-id 1 1 "COMPLETED" "PASS" "Just testing!")) +(test #f #t (list? (rmt:get-tests-for-run 1 "%" '() '() #f #f #f #f #f #f 0 #f))) +(test #f #t (list? (rmt:get-tests-for-runs-mindata '(1) "%" '() '() #f))) +(test #f #f (begin (rmt:delete-test-records 1 2) #f)) +(test #f #t (begin (rmt:test-set-state-status 1 1 "COMPLETED" "FAIL" "Another message") #t)) +(test #f 0 (rmt:test-toplevel-num-items 1 "foo")) +(test #f '()(rmt:get-matching-previous-test-run-records 1 "foo" "")) +(test #f '("/tmp/badname" "logs/final.log") (rmt:test-get-logfile-info 1 "foo")) +(test #f '()(rmt:test-get-records-for-index-file 1 "foo")) +(test #f #t (vector? (rmt:get-testinfo-state-status 1 1))) +(test #f #t (rmt:test-set-log! 1 1 "/tmp/another/logfile/eh")) +(test #f #f (begin (rmt:test-set-top-process-pid 1 1 123) #f)) +(test #f 123 (rmt:test-get-top-process-pid 1 1)) +(define keys (rmt:get-keys)) +(test #f '()(rmt:get-run-ids-matching-target keys "%/%" #f "%" "%" "%" "%")) +(test #f '()(rmt:test-get-paths-matching-keynames-target-new keys "%/%" #f "%" "%" "%" "%")) +(test #f '()(rmt:get-prereqs-not-met 1 '() "foo" "")) +(test #f 0 (rmt:get-count-tests-running-for-run-id 1)) +(test #f 0 (rmt:get-count-tests-running 1)) +(test #f 0 (rmt:get-count-tests-running-for-testname 1 "foo")) +(test #f 0 (rmt:get-count-tests-running-in-jobgroup 1 "nada")) +(test #f #f (begin (rmt:set-state-status-and-roll-up-items 1 "foo" "" "COMPLETED" "FAIL" "Just yet another message") #f)) +(test #f #t (rmt:top-test-set-per-pf-counts 1 "foo")) +(test #f '() (rmt:get-raw-run-stats 1)) +(test #f #t (vector? (rmt:get-run-info 1))) +(test #f 0 (rmt:get-num-runs "%")) +(define keypatts '(("SYSTEM" "ubuntu")("RELEASE" "v1.234")) ) +(test #f 1 (rmt:register-run '(("SYSTEM" "ubuntu")("RELEASE" "v1.234")) "bar" "NEW" "JUSTFINE" "bobafett" "quick")) +(test #f "bar" (rmt:get-run-name-from-id 1)) +(test #f #t (begin (rmt:delete-run 2) #t)) ;; delete a non-existant run +(test #f #t (begin (rmt:update-run-stats 1 '()) #t)) +(test #f #t (begin (rmt:delete-old-deleted-test-records) #t)) +(test #f #t (vector? (rmt:get-runs "%" 10 0 keypatts))) +(test #f '(1)(rmt:get-all-run-ids)) +(test #f '()(rmt:get-prev-run-ids 1)) +(test #f #t (begin (rmt:lock/unlock-run 1 #t #f "mikey") #t)) +(test #f "JUSTFINE" (rmt:get-run-status 1)) +(test #f #t (begin (rmt:set-run-status 1 "NOTFINE" msg: "A message") #t)) +(test #f #t (begin (rmt:update-run-event_time 1) #t)) + +;; (rmt:get-runs-by-patt keys runnamepatt targpatt offset limit fields last-runs-update) ;; fields of #f uses default +;; +(let ((keys (rmt:get-keys)) + (rnp "%") ;; run name patt + (tpt "%/%")) ;; target patt + (test-batch rmt:get-runs-by-patt + "rmt:get-runs-by-patt" + (list (list "t=0" #t keys rnp tpt #f #f #f 0) + (list "t=current" #f keys rnp tpt #f #f #f (+ 100 (current-seconds))) ;; should be no records from the future + ) + post-proc: (lambda (res) + ;; (print "rmt:get-runs-by-patt returned: " res) + (and (vector? res) + (let ((rows (vector-ref res 1))) + (> (length rows) 0)))))) + +;; (rmt:find-and-mark-incomplete run-id ovr-deadtime) +;; (rmt:get-main-run-stats run-id) +;; (rmt:get-var varname) +;; (rmt:set-var varname value) +;; (rmt:find-and-mark-incomplete-all-runs #!key (ovr-deadtime #f)) +;; (rmt:get-previous-test-run-record run-id test-name item-path) +;; (rmt:get-run-stats) +;; (rmt:teststep-set-status! run-id test-id teststep-name state-in status-in comment logfile) +;; (rmt:get-steps-for-test run-id test-id) +;; (rmt:read-test-data run-id test-id categorypatt #!key (work-area #f)) +;; (rmt:testmeta-add-record testname) +;; (rmt:testmeta-get-record testname) +;; (rmt:testmeta-update-field test-name fld val) +;; (rmt:test-data-rollup run-id test-id status) +;; (rmt:csv->test-data run-id test-id csvdata) +;; (rmt:tasks-find-task-queue-records target run-name test-patt state-patt action-patt) +;; (rmt:tasks-add action owner target runname testpatt params) +;; (rmt:tasks-set-state-given-param-key param-key new-state) +;; (rmt:tasks-get-last target runname) +;; (rmt:archive-get-allocations testname itempath dneeded) +;; (rmt:archive-register-block-name bdisk-id archive-path) +;; (rmt:archive-allocate-testsuite/area-to-block block-id testsuite-name areakey) +;; (rmt:archive-register-disk bdisk-name bdisk-path df) +;; (rmt:test-set-archive-block-id run-id test-id archive-block-id) +;; (rmt:test-get-archive-block-info archive-block-id) +;; NED (rmt:open-qry-close-locally cmd run-id params #!key (remretries 5)) +;; NED (rmt:send-receive cmd rid params #!key (attemptnum 1)(area-dat #f)) ;; start attemptnum at 1 so the modulo below works as expected +;; DEF (test #f #f (rmt:print-db-stats)) +;; DEF (rmt:get-max-query-average run-id) +;; NED (rmt:general-call stmtname run-id . params) +;; DEP (rmt:sdb-qry qry val run-id) +;; DEF (rmt:runtests user run-id testpatt params) +;; DEP (rmt:open-test-db-by-test-id run-id test-id #!key (work-area #f)) +;; DEP (rmt:synchash-get run-id proc synckey keynum params) +;; DEP (test #f #f (rmt:update-pass-fail-counts 1 "foo")) ADDED tests/unittests/cron.scm Index: tests/unittests/cron.scm ================================================================== --- /dev/null +++ tests/unittests/cron.scm @@ -0,0 +1,19 @@ + +(use test) + +;; S M H MD MTH YR WD +(define ref-time (vector 58 39 21 18 1 117 6 48 #f 25200)) + +(for-each + (lambda (situation crontab ref-seconds last-done expected) + (print "\nsituation: " situation) + (print "ref-seconds: " ref-seconds " = " (time->string (seconds->local-time ref-seconds))) + (print "last-done: " last-done " = " (time->string (seconds->local-time last-done))) + (print "crontab: " crontab) + (test #f expected (common:cron-event crontab ref-seconds last-done))) + '("midnight" "midnight, already done" "diffdate" "diffdate, already done" "diffday" "sameday, already done") + '("0 0 * * *" "0 0 * * *" "0 0 18 * *" "0 0 18 * *" "0 0 * * 5" "0 0 18 * 6" ) + '(1487489998.0 1487489998.0 1487489998.0 1487489998.0 1487489998.0 1487489998.0 ) + '(1487479198.0 1487489098.0 1487479198.0 1487489098.0 1487479198.0 1487489098.0 ) + '( #t #f #f #f #f #f ) + ) Index: tests/unittests/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) 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 @@ -22,11 +22,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") 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/fslrept.scm Index: utils/fslrept.scm ================================================================== --- /dev/null +++ utils/fslrept.scm @@ -0,0 +1,91 @@ + +(use json fmt posix) + +;; abstract out the alist-ref a bit and re-order the params +;; +(define-inline (aref dat key) + (alist-ref key dat equal?)) + +;; convert silly vectors in json data to nice clean alist +;; +(define (to-alist inlst) + (handle-exceptions + exn + (begin + (print-call-chain) + (print inlst)) + (cond + ((proper-list? inlst) (map to-alist inlst)) + ((or (list? inlst) ;; it is a pair + (pair? inlst)) (cons (car inlst) (to-alist (cdr inlst)))) + ((vector? inlst) (to-alist (vector->list inlst))) + (else inlst)))) + +;; columnar line printer +;; +(define (print-rows inlist) + (define (print-line x) + (cat (car x) + (space-to 10)(pad/left 3 (cadr x)) + (space-to 25)(pad/left 3 (caddr x)) + )) + (fmt #t (pad-char #\ (fmt-join/suffix print-line inlist nl)))) + +;; from the command line pull branch, start-tag, end-tag +;; +(define (extract-history branch start-tag end-tag) + (let* ((data (to-alist ;; get all the data + (with-input-from-pipe + "fossil json timeline checkin -n 0" + json-read))) + (timeline (aref (aref data "payload") "timeline")) ;; extract the timeline alists + (start-flag #f) + (end-flag #f)) + ;; now we have all needed data as a list of alists in time order, extract the + ;; messages for given branch starting at start-tag and ending at end-tag + (reverse ;; return results oldest to newest + (filter + (lambda (x) x) + (map + (lambda (entry) + (let ((tags (aref entry "tags"))) + (if (or (not tags) ;; eh? + (not (list? tags))) + (begin + ;; (with-output-to-port (current-error-port) + ;; (lambda () + ;; (print "ERROR: bad entry. tags: " tags))) + #f) + (let* ((btag (car tags)) ;; first tag is the primary branch + (tags (cdr tags)) ;; remainder are actual tags + (cmt (aref entry "comment")) + (usr (aref entry "user")) + (tms (aref entry "timestamp"))) + ;; (print "btag: " btag " tags: " tags " usr: " usr) + (if (equal? btag branch) ;; we are on the branch + (begin + (if (member start-tag tags)(set! start-flag #t)) + (let ((res (if (and start-flag + (not end-flag)) + `(,usr + ,(time->string (seconds->local-time tms) "WW%U.%w %H:%M") + ,cmt) + #f))) + (if (member end-tag tags)(set! end-flag #t)) + res)) + #f))))) + (reverse timeline)))))) + +(define (process-fossil branch start-tag end-tag) + (print-rows + (extract-history branch start-tag end-tag))) + +;; process command line args and dispatch the call to fossil processing +;; +(if (and (> (length (argv)) 3) + (< (length (argv)) 5)) + (apply process-fossil (cdr (argv))) + (begin ;; no inputs, exit with message + (print "Usage: fslrept branch start-tag end-tag") + )) + Index: utils/installall.sh ================================================================== --- utils/installall.sh +++ utils/installall.sh @@ -1,7 +1,10 @@ #! /usr/bin/env bash +# This file installs prerequisites for megatest (chicken, eggs, etc.) +# Before running this script, set PREFIX environment variable +# to chicken install target area. /opt/chicken is a typical value # set -x # Copyright 2007-2014, Matthew Welland. # # This program is made available under the GNU GPL version 2.0 or @@ -8,45 +11,65 @@ # 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. + +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 -echo sudo apt-get install 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 echo echo Set OPTION to std, currently OPTION=$OPTION echo echo Additionally, if you want mysql-client, you will need to make sure echo mysql_config is in your path +echo for postgres to install dbi libpq-dev echo echo You are using PREFIX=$PREFIX echo You are using proxy="$proxy" echo echo "Set additional_libpath to help find gtk or other libraries, don't forget a leading :" SYSTEM_TYPE=$(lsb_release -irs |tr ' ' '_' |tr '\n' '-')$(uname -i)-$OPTION +CHICKEN_VERSION=4.11.0 +CHICKEN_BASEVER=4.11.0 + # Set up variables # case $SYSTEM_TYPE in +Ubuntu-17.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 + ;; 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 ;; Ubuntu-16.04-i686-std) KTYPE=32 CDVER=5.10 IUPVER=3.17 IMVER=3.11 + CHICKEN_VERSION=4.12.0 + CHICKEN_BASEVER=4.12.0 ;; SUSE_LINUX_11-x86_64-std) KTYPE=26g4 CDVER=5.10 IUPVER=3.17 @@ -57,15 +80,19 @@ 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 @@ -90,10 +117,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' @@ -104,12 +132,10 @@ # Put all the downloaded tar files in tgz mkdir -p tgz # http://code.call-cc.org/releases/4.8.0/chicken-4.8.0.5.tar.gz -export CHICKEN_VERSION=4.11.0 -export CHICKEN_BASEVER=4.11.0 chicken_targz=chicken-${CHICKEN_VERSION}.tar.gz if ! [[ -e tgz/$chicken_targz ]]; then wget http://code.call-cc.org/releases/${CHICKEN_BASEVER}/${chicken_targz} mv $chicken_targz tgz fi @@ -144,22 +170,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/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 + 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 @@ -173,18 +202,31 @@ tar xfz tgz/sqlite-autoconf-$SQLITE3_VERSION.tar.gz (cd sqlite-autoconf-$SQLITE3_VERSION;./configure --prefix=$PREFIX;make;make install) fi fi fi + + + cd $BUILDHOME +for egg in "sqlite3" sql-de-lite # nanomsg +do + echo "Installing $egg" + CSC_OPTIONS="-I$PREFIX/include -L$PREFIX/lib -L$PREFIX/lib64" $CHICKEN_INSTALL $PROX -keep-installed $egg + #CSC_OPTIONS="-I$PREFIX/include -L$PREFIX/lib -L$PREFIX/lib64" $CHICKEN_INSTALL $PROX $egg + if [ $? -ne 0 ]; then + echo "$egg failed to install" + exit 1 + fi +done # Some eggs are quoted since they are reserved to Bash # for f in matchable readline apropos base64 regex-literals format "regex-case" "test" coops trace csv dot-locking posix-utils posix-extras directory-utils hostinfo tcp rpc csv-xml fmt json md5; do # $CHICKEN_INSTALL $PROX -keep-installed matchable readline apropos base64 regex-literals format "regex-case" "test" coops trace csv dot-locking posix-utils posix-extras directory-utils hostinfo tcp rpc csv-xml fmt json md5 awful http-client spiffy uri-common intarweb http-client spiffy-request-vars md5 message-digest http-client spiffy-directory-listing 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 \ 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 \ @@ -191,11 +233,11 @@ 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 do echo "Installing $egg" $CHICKEN_INSTALL $PROX -keep-installed $egg #$CHICKEN_INSTALL $PROX $egg @@ -207,20 +249,10 @@ if [[ -e `which mysql_config` ]]; then $CHICKEN_INSTALL $PROX -keep-installed mysql-client fi -for egg in "sqlite3" sql-de-lite # nanomsg -do - echo "Installing $egg" - CSC_OPTIONS="-I$PREFIX/include -L$PREFIX/lib -L$PREFIX/lib64" $CHICKEN_INSTALL $PROX -keep-installed $egg - #CSC_OPTIONS="-I$PREFIX/include -L$PREFIX/lib -L$PREFIX/lib64" $CHICKEN_INSTALL $PROX $egg - if [ $? -ne 0 ]; then - echo "$egg failed to install" - exit 1 - fi -done cd $BUILDHOME cd `$PREFIX/bin/csi -p '(chicken-home)'` curl http://3e8.org/pub/chicken-doc/chicken-doc-repo.tgz | tar zx cd $BUILDHOME @@ -343,12 +375,22 @@ CSC_OPTIONS="-I$PREFIX/include -L$PREFIX/lib" $CHICKEN_INSTALL $PROX -D no-library-checks canvas-draw # CSC_OPTIONS="-I$PREFIX/include -L$CSCLIBS" $CHICKEN_INSTALL $PROX -D no-library-checks -deploy -prefix $DEPLOYTARG canvas-draw cd $BUILDHOME +# install ducttape +if [[ -e ../ducttape ]];then + cd ../ducttape + $CHICKEN_INSTALL +else + echo "ducttape egg not found at ../ducttape. You will need to cd into the ducttape directory in the megatest distribution and run \"chicken-install\"" +fi + +cd $BUILDHOME echo You may need to add $LD_LIBRARY_PATH to your LD_LIBRARY_PATH variable, a setup-chicken4x.sh echo file can be found in the current directory which should work for setting up to run chicken4x + echo Testing iup $PREFIX/bin/csi -b -eval '(use iup)(print "Success")' Index: utils/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/nbfake ================================================================== --- utils/nbfake +++ utils/nbfake @@ -4,10 +4,12 @@ # nbfake - capture command output in a logfile # # nbfake behavior can be changed by setting the following env vars: # NBFAKE_HOST SSH to $NBFAKE_HOST and run command # NBFAKE_LOG Logfile for nbfake output +# NB_WASH_GROUPS comma-separated list of groups to wash into +# NB_WASH_ENABLED must be set in order to enable wash groups # ############################################################################### if [[ -z "$@" ]]; then cat <<__EOF @@ -17,10 +19,12 @@ nbfake nbfake behavior can be changed by setting the following env vars: NBFAKE_HOST SSH to \$NBFAKE_HOST and run command NBFAKE_LOG Logfile for nbfake output + NB_WASH_GROUPS comma-separated list of groups to wash into + NB_WASH_ENABLED must be set in order to enable wash groups __EOF exit fi @@ -53,24 +57,31 @@ # Set default nbfake log if [[ -z "$MY_NBFAKE_LOG" ]]; then MY_NBFAKE_LOG=NBFAKE-$(date +%GWW%V.%u_%T) fi + +# wash groups handling. Default is no action +WASHCMD="" +if [[ -n ${NB_WASH_ENABLED+1} && -n ${NB_WASH_GROUPS+1} ]]; then + grouplist=`echo $NB_WASH_GROUPS | tr ',' ' '` + WASHCMD="wash -q -n $grouplist -X" +fi #============================================================================== # Run and log #============================================================================== cat <<__EOF >&2 #====================================================================== # NBFAKE logging command to: $MY_NBFAKE_LOG -# $* +# $WASHCMD $* #====================================================================== __EOF if [[ -z "$MY_NBFAKE_HOST" ]]; then # Run locally - sh -c "cd $CURRWD;export DISPLAY=$DISPLAY; export PATH=$PATH; nohup $* >> $MY_NBFAKE_LOG 2>&1 &" + sh -c "cd $CURRWD;export DISPLAY=$DISPLAY; export PATH=$PATH; nohup $WASHCMD $* >> $MY_NBFAKE_LOG 2>&1 &" else # run remotely - ssh -X -n -f $MY_NBFAKE_HOST "sh -c \"cd $CURRWD;export DISPLAY=$DISPLAY; export PATH=$PATH; nohup $* >> $MY_NBFAKE_LOG 2>&1 &\"" + ssh -X -n -f $MY_NBFAKE_HOST "sh -c \"cd $CURRWD;export DISPLAY=$DISPLAY; export PATH=$PATH; nohup $WASHCMD $* >> $MY_NBFAKE_LOG 2>&1 &\"" fi ADDED utils/triage.rb Index: utils/triage.rb ================================================================== --- /dev/null +++ utils/triage.rb @@ -0,0 +1,79 @@ +#!/usr/bin/env ruby + +#dir = "." +#if ARGV.length == 1 +# dir = ARGV[0] +#end +#puts dir +#exit 1 + +allfiles = [] +server_logs = `find logs/ -type f -name 'server*.log' 2>/dev/null`.split /\n/ +allfiles += server_logs +ARGV.each{|dir| + nbfiles = `find #{dir} -type f -name '##*' 2>/dev/null`.split /\n/ + fakefiles = `find #{dir} -type f -name 'NBFAKE-*' 2>/dev/null`.split /\n/ + allfiles = allfiles + nbfiles + fakefiles +} + +buckets = Hash.new{|h,k| h[k]=[]} +#;buckets['OK'] = [] +#;buckets['stackdump'] = [] + + +sig_patterns = [ + 'cannot create directory - File exists', + 'in thread: $finalize!$ bad argument type - not a database or statement: #', + 'cannot delete file - No such file or directory: .*\/.runconfig.', + 'Error: $hash-table-ref/default$ bad argument type - not a structure of the required type', + '$#$: in thread: $open-output-file$ cannot open file - File exists:', + 'http-transport.scm:442: posix-extras#change-file-times', + 'thread: $file-exists\?$ system error while trying to access file:', + 'error: database is locked', + 'Finalizing failed, unable to close due to unfinalized statements or unfinished backups', + 'rmt.scm:276: current-milliseconds', + 'http-transport.scm:366: exit', + 'should never happen', + 'FATAL: \*configdat\* was inaccessible! This should never happen.', + 'FATAL ERROR: http-transport:client-api-send-receive called with no server info', + '!!ISOENV PRESENT!!' + + ] + +allfiles.each{|logfile| + bucket = 'OK' + open(logfile){|fh| + fh.each{|line| + + if line.match(/Call history/) + if bucket == 'OK' + bucket='??' + end + end + sig_patterns.each_with_index{|pat,bucket_name| + #bucket_name,pat = i + if line.match(/#{pat}/) + bucket=bucket_name + end + } + + } + } + buckets[bucket] << logfile +} + +puts "count\tsignature\texample file" +buckets.keys.each{|bucket| + count = buckets[bucket].length + + example = buckets[bucket][0] + if example + puts "#{count}\tsignature-#{bucket}\t#{example}" + if bucket.to_s.match(/^[0-9]+$/) + puts " `- pattern = /#{sig_patterns[bucket]}/" + end + else + puts "#{count}\tsignature-#{bucket}" + end +} +#puts buckets['stackdump'][0] ADDED utils/unlock_db.sh Index: utils/unlock_db.sh ================================================================== --- /dev/null +++ utils/unlock_db.sh @@ -0,0 +1,27 @@ +#!/bin/bash + +## Enh : +# 1. if /tmp/repo exists, delte it or name it something else +# 2. compare the repo is successfully created + +## Usage : +# unlock_db.sh + +function unlock_db () { + repo=$1 + echo $repo + ls -lrt $repo + cp $repo /tmp/${USER}_repo.tmp + ls -lrt /tmp/${USER}_repo.tmp + ## Eventually compare the sizes of 2 repos + cmd=$(rm -r $repo && sqlite3 /tmp/${USER}_repo.tmp .dump | sqlite3 $repo) + echo $cmd + ls -lrt $repo + chmod g+w $repo +} + +#====================================================================== +# T H E M A I N H A N D L E R A N D P R O C E S S I N G +#====================================================================== + +unlock_db $1 ADDED utils/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,48 @@ +(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))))) + ADDED utils/wip/mtest-dbstop.scm Index: utils/wip/mtest-dbstop.scm ================================================================== --- /dev/null +++ utils/wip/mtest-dbstop.scm @@ -0,0 +1,12 @@ +#!/p/foundry/env/pkgs/chicken/4.10.0_ext/bin/csi -s + +(use chicken) +(use data-structures) + + +(include "/nfs/site/home/bjbarcla/bin2/mtest-repair-lib.scm") +(glib-color-mode 1) + +(set! *this-cmd* "/nfs/site/home/bjbarcla/bin2/mtest-dbstop.scm") +(kill-in-db) + ADDED utils/wip/mtest-diag.scm Index: utils/wip/mtest-diag.scm ================================================================== --- /dev/null +++ utils/wip/mtest-diag.scm @@ -0,0 +1,165 @@ +#!/p/foundry/env/pkgs/chicken/4.10.0_ext/bin/csi -s + +(use chicken) +(use data-structures) + + +(include "/nfs/site/home/bjbarcla/bin2/mtest-repair-lib.scm") +(glib-color-mode 1) + +;;; check mtver in xterm +(let ((mt-ver (do-or-die "megatest -version"))) + (when (member mt-ver '("1.6309-738c" "1.6029")) + (iwarn "This xterm has an older version of megatest.") + (ierr "Please load latest megatest version to proceed.") + (print "eg.: source ../scripts/newrel-setup.csh 1.63/11b") + (exit 3))) + + +;;;; kill netbatch jobs from this megatest +;; TODO! + + +(define *diag* #t) +;;(define *user* (get-environment-variable "USER")) +(define *user* (do-or-die "ls -ld . | awk '{print $3}'")) +(print "user="*user*) +;;;; delete .homehost .homehost.config +;;;; if not on homehost, ssh homehost, cd here, killall mtest dboard +(if (not *diag*) + (when (file-exists? ".homehost.config") + (delete-db ".homehost.config"))) + +(when (file-exists? ".homehost") + (let* ((homehost (with-input-from-file ".homehost" (lambda () (read))))) + (let* ((homehostname (do-or-die "host `cat .homehost` | sed 's/.$//' | awk '{print $NF}' | awk -F. '{print $1}'")) + (thishostname (get-environment-variable "HOST"))) + (when (not (equal? homehostname thishostname)) + (let* ((this-exe-compiled (car (argv))) + (this-exe "/nfs/site/home/bjbarcla/bin2/mtest-diag.scm") + (cmd (conc "ssh "homehostname" 'cd "(get-environment-variable "PWD")" && "this-exe"'"))) + (iwarn "Running on the homehost -- "homehostname) + ;;(iwarn "eg: % ssh "homehostname" 'cd "(get-environment-variable "PWD")" && "(car (argv))"'") + (print "cmd="cmd) + ;;(inote "sleeping for 5 seconds. hit ctrl-c now to run on homehost or wait to proceed.") + (system cmd) + (exit 0)))))) + + + + +;;;; kill megatests and dashboards in this area +(define (kill-mtest-dboard) + (if *diag* + #f + (let* ((this-toppath (pid->cwd (current-process-id))) + (tmppath (toppath->tmppath this-toppath)) + (config (let ((res (conc this-toppath "/megatest.config"))) + (when (not (file-exists? res)) + (ierr "This is not a megatest run area; "res" does not exist. Aborting.") + (exit 2)) + res)) + (mtest-procs (get-my-mtest-procs)) + (dashboard-procs (get-my-dashboard-procs)) + (all-pids (map proc-PID (append mtest-procs dashboard-procs))) + (our-pids (filter (lambda (pid) + (equal? (pid->cwd pid) this-toppath)) + all-pids))) + + (if (null? our-pids) + (inote "No mtest or dboard processes on this host in in this runarea.") + (begin + (iwarn "Killing all megatest and dashboard processes on this host.") + (gracefully-kill-pids our-pids))) + ))) + +(kill-mtest-dboard) + + +;;;; delete /tmp/.$USER-portlogger.db +(let ((plfile (conc "/tmp/."*user* "-portlogger.db"))) + + (if (safe-file-exists? plfile) + (if *diag* + (print "plfile exists - "plfile) + (begin + (inote "removing portlogger file") + (system (conc "rm "plfile)))))) + + +;;;; move logs dir aside +(when (not *diag*) + (system (conc "mv logs logs-aside-`date +%s`")) + (system "mkdir logs")) + + +;;;; fixes for dependency diagram +(when (not *diag*) + (inote "Removing dep graph tmp files if they exist") + (system (conc "rm /tmp/."*user*"-*.dot")) + + ;;#ln -s /p/fdk/gwa/$USER/fossil/ext/_ext ext + (let* ((toppath (pid->cwd (current-process-id))) + (flow (car (string-split + (car (reverse (string-split toppath "/"))) + "."))) + (extdir (conc "/p/fdk/gwa/"*user* + "/fossil/ext/"flow"_ext"))) + (when (and (safe-file-exists? extdir) + (not (safe-file-exists? "ext"))) + (inote "Linking in ext dir") + (system (conc "ln -s "extdir" ext"))))) + + +;;;; check for 0 byte megatest{,_ref}.db in tmp. delete them +;;;; check for wal-mode megatest{,_ref}.db in tmp. delete them +(define (repair-dbs) + (let* ((this-toppath (pid->cwd (current-process-id))) + (tmppath (toppath->tmppath this-toppath)) + (golden-mtest-file (conc this-toppath "/megatest.db")) + (golden-mtest-file-ok (check-db "megatest.db")) + (tmp-mtest-file (conc tmppath "/megatest.db")) + (tmp-mtestref-file (conc tmppath "/megatest_ref.db")) + (tmp-mtest-file-ok (check-db tmp-mtest-file)) + (tmp-mtestref-file-ok (check-db tmp-mtestref-file)) + ) +;;;; check for megatest{,_ref}.db in tmp that die on .schema. delete them + (when (safe-file-exists? tmppath) + (if tmp-mtest-file-ok + (inote "tmp megatest db file ok") + (if *diag* + (print "diag: tmp megatest db broken - "tmp-mtest-file) + (delete-db tmp-mtest-file))) + (if tmp-mtestref-file-ok + (inote "tmp megatestref db file ok") + (if *diag* + (print "diag: tmpref megatest db broken - "tmp-mtestref-file) + (delete-db tmp-mtestref-file)))) + +;;;; check for megatest.db + (if golden-mtest-file-ok + (inote "golden megatest db file ok") + (if (not (file-exists? golden-mtest-file)) + (inote "megatest.db not present. Continuing.") + (begin + ;;;; if golden megatest db is broken, stop now! + (ierr "Golden megatest.db is broken. Please delete it or replace it from a backup version in .snapshot. If critical, contact env team to assist.") + (sendmail "bjbarcla" "!!Bad golden megatest.db" this-toppath) + (inote "Backups in .snapshot:") + (system "ls -l .snapshot/*/megatest.db") + (ierr "Not proceeding with any more checks.") + (exit 3)))) + + + + )) + +(repair-dbs) + + + + + + + + ADDED utils/wip/mtest-nbstop.scm Index: utils/wip/mtest-nbstop.scm ================================================================== --- /dev/null +++ utils/wip/mtest-nbstop.scm @@ -0,0 +1,34 @@ +#!/p/foundry/env/pkgs/chicken/4.10.0_ext/bin/csi -s + +(use chicken) +(use data-structures) + + +(include "/nfs/site/home/bjbarcla/bin2/mtest-repair-lib.scm") +(glib-color-mode 1) + +(set! *this-cmd* "/nfs/site/home/bjbarcla/bin2/mtest-nbstop.scm") + +(inote "Killing local mtest/dboard in this run area.") +(kill-mtest-dboard) + +;;;; move logs dir aside +(inote "move logs") +(system (conc "mv logs logs-aside-`date +%s`")) +(system "mkdir logs") + + + +(inote "Killing netbatch mtest jobs launched from this run area.") +(let ((jobcount (kill-mtest-jobs-in-netbatch))) + (when (> jobcount 0) + (inote "Marking in-flight tests killed in db") + (when (db-islocked? "megatest.db") + (iwarn "Unlocking megatest.db") + (db-unlock "megaetest.db")) + (kill-in-db))) + +(inote "Final reaping of mtest/dboard") +(kill-mtest-dboard) + + ADDED utils/wip/mtest-reaper.scm Index: utils/wip/mtest-reaper.scm ================================================================== --- /dev/null +++ utils/wip/mtest-reaper.scm @@ -0,0 +1,142 @@ +#!/p/foundry/env/pkgs/chicken/4.10.0_ext/bin/csi -s + +(use general-lib) +(use typed-records) +(use regex-literals) +(use regex) +(use sql-de-lite) + +(defstruct proc + (USER "") + (PID -1) + (%CPU -1.0) + (%MEM -1.0) + (VSZ -1) + (RSS -1) + (TTY "") + (STAT "") + (START "") + (TIME "") + (COMMAND "")) + +(define (linux-get-process-info-records) + (let* ((raw (do-or-die "/bin/ps auwx")) + (all-lines (string-split raw "\n")) + (lines (cdr all-lines)) ;; skip title lines + (re #/^(\S+)\s+(\d+)\s+(\S+)\s+(\S+)\s+(\S+)\s+(\S+)\s+(\S+)\s+(\S+)\s+(\S+)\s+(\S+)\s+(.*)$/)) + (filter + proc? + (map + (lambda (line) + (let ((match (string-match re line))) + (if match + (make-proc + USER: (list-ref match 1) + PID: (string->number (list-ref match 2)) + %CPU: (string->number (list-ref match 3)) + %MEM: (string->number (list-ref match 4)) + VSZ: (string->number (list-ref match 5)) + RSS: (string->number (list-ref match 6)) + TTY: (string->number (list-ref match 7)) + STAT: (list-ref match 8) + START: (list-ref match 9) + TIME: (list-ref match 10) + COMMAND: (list-ref match 11)) + #f))) + lines)))) + +(define (get-my-mtest-server-procs) + (let* ((procs (linux-get-process-info-records)) + (my-mtest-procs + (filter + (lambda (a-proc) + (and + (equal? (get-environment-variable "USER") (proc-USER a-proc)) + (string-match #/^.*\/mtest\s+.*-server.*/ (proc-COMMAND a-proc)))) + procs))) + my-mtest-procs)) + + +(define (pid->environ-hash pid) + (let* ((envfile (conc "/proc/"pid"/environ")) + (ht (make-hash-table)) + (rawdata (with-input-from-file envfile read-string)) + (lines (string-split rawdata (make-string 1 #\nul )))) + (for-each + (lambda (line) + (let ((match (string-match #/(^[^=]+)=(.*)/ line))) + (if match + (hash-table-set! ht (list-ref match 1) (list-ref match 2))))) + lines) + ht)) + +(define (pid->cwd pid) + (read-symbolic-link (conc "/proc/"pid"/cwd"))) + +(define (pid->mtest-monitor-db-file pid) + (let* ((env (pid->environ-hash pid)) + (ltdir (hash-table-ref/default env "MT_LINKTREE" #f)) + (radir (hash-table-ref/default env "MT_RUN_AREA_HOME" #f)) + (cwd (pid->cwd pid))) + (let ((res + (cond + (ltdir (conc ltdir "/.db/monitor.db")) + (radir (conc + (do-or-die + (conc "megatest -start-dir "radir" -show-config -section setup -var linktree")) + "/.db/monitor.db")) + (cwd (conc + (do-or-die + (conc "megatest -start-dir "cwd" -show-config -section setup -var linktree")) + "/.db/monitor.db")) + + (else #f)))) + res))) + + + + + +(define (get-mdb-status mdb-file pid) + ;; select state from servers where pid='4465'; + + (cond + ((not (string? mdb-file)) (conc "mdb-file could not be determined for pid " pid ">>"mdb-file )) + ((not (file-exists? mdb-file)) (conc "mdb-file does not exist for pid "pid" : "mdb-file)) + (else + (let ((dbh (open-database mdb-file))) + + (set-busy-handler! dbh 10000) + (let* ((sql-str "select state from servers where pid=?;") + (stm (sql dbh sql-str)) + (alists (query fetch-alists stm (->string pid)))) + (if (null? alists) + "server pid not in monitor.db" + (cdr (car (car alists))))))))) + + +(define (mtest-server-pid->status pid) + (let* ((mdb-file (pid->mtest-monitor-db-file pid))) + (if mdb-file + (get-mdb-status mdb-file pid) + "no monitor.db file could be found" + ))) + + +(define (kill pid) + (print "KILL "pid) + (do-or-die (conc "kill -9 "pid))) + +(define (reap-defunct-mtest-server-pid pid) + (let ((status (mtest-server-pid->status pid))) + (print pid"->"(mtest-server-pid->status pid)) + (if (member status (list "running" "dbprep" "available" "collision")) + (print "pid="pid" in status "status" -- not killing") + (kill pid)))) + +(let* ((procs (get-my-mtest-server-procs)) + (pids (map proc-PID procs)) + ) + + (for-each reap-defunct-mtest-server-pid pids)) + ADDED utils/wip/mtest-repair-lib.scm Index: utils/wip/mtest-repair-lib.scm ================================================================== --- /dev/null +++ utils/wip/mtest-repair-lib.scm @@ -0,0 +1,508 @@ +(use general-lib) +(use typed-records) +(use regex-literals) +(use regex) +(use sql-de-lite) +(use posix) +(use files) +(use s11n) +(use ports) +(use z3) +(use base64) +(use matchable) + + + + +(define (cli-arg arg #!key (default #f) (is-list #f)) + (let* ((temp (skim-cmdline-opts-withargs-by-regex arg))) + (if (> (length temp) 0) + (if is-list + temp + (car temp)) + default))) + +(define (cli-switch arg) + (let ((temp (skim-cmdline-opts-noarg-by-regex arg))) + (if (> (length temp) 0) + (car temp) + #f))) + + + +(defstruct nbjob + pool + jobid + owner + mtver + user + status + cmdline + execute) + +(define (cmdline->execute cmdline) + (let* ((match (string-match ".*-execute\\s+(\\S+)" cmdline))) + (if match + (with-input-from-string (z3:decode-buffer (base64-decode (cadr match))) read) + #f))) + + +(define (nbjob-execute-ref nbjob key #!key (default #f)) + (let ((execute (nbjob-execute nbjob))) + (if (list? execute) + (let* ((match (alist-ref key execute))) + (if match + (if (list? match) (car match) match) + default)) + default))) + +(define (nbjob-process pool nbstatus-line) + (let ((toks (string-split nbstatus-line ","))) + (if (eq? 4 (length toks)) + (if (equal? (list-ref toks 1) "Jobid") + #f + (begin + (let ((res + (make-nbjob + pool: pool + status: (list-ref toks 0) + jobid: (list-ref toks 1) + user: (list-ref toks 2) + cmdline: (list-ref toks 3) + execute: (cmdline->execute (list-ref toks 3)) + ))) + res))) + #f))) + +(define (get-mtest-nb-jobs user nbpools #!key (cmdline-filter "megatest")) + (let* ((res + (apply append + (map (lambda (pool) + (let* (;;(user-filter ".*") + (user-filter user) + (cmd + (conc "nbstatus jobs --tar "pool" --fields status,jobid,user,cmdline --format csv " + "'USER=~\""user-filter + "\"&&cmdline=~\""cmdline-filter"\"'")) + (res (do-or-die cmd))) + (filter nbjob? + (map (lambda (line) + (nbjob-process pool line)) + (string-split res "\n"))))) + nbpools)))) + res)) + +;;(define foo (get-mtest-nb-jobs "bjbarcla" '("pdx_normal" "pdx_critical"))) + +(define (cmdline->execute cmdline) + (let* ((match (string-match ".*-execute\\s+(\\S+)" cmdline))) + (if match + (with-input-from-string (z3:decode-buffer (base64-decode (cadr match))) read) + #f))) + +;;;; kill jobs in netbatch for this area +(define (kill-mtest-jobs-in-netbatch) + (let ((pwd (get-environment-variable "PWD")) + (jobs (get-mtest-nb-jobs (get-environment-variable "USER") '("pdx_normal" "pdx_critical") ))) + + (for-each + (lambda (job) + (let* ((jobid (nbjob-jobid job)) + (pool (nbjob-pool job)) + (status (nbjob-status job)) + (cmd (conc "nbjob --target "pool" remove "jobid))) + ;;(print status) + (print cmd) + (system cmd))) + ;(pp (nbjob->alist job)) + (filter + (lambda (job) + (equal? (nbjob-execute-ref job 'toppath) pwd)) + jobs)) + (length jobs) + + )) + + +;;;; kill megatest jobs in running in netbatch +(define (kill-in-db #!key (megatest_exe "megatest")) + (let* ((all-targ-patt (do-or-die "sqlite3 megatest.db \"select id from keys\" | tr \"\\n1234567890\" \"/%%%%%%%%%%\" | sed 's/\\/$//'")) + ) + (for-each (lambda (state) + (let* ((cmd (conc megatest_exe " -state "state" -set-state-status KILLED,n/a -testpatt % -target "all-targ-patt" -runname %"))) + (print cmd) + (system cmd))) + '("REMOTEHOSTSTART" "LAUNCHED" "RUNNING" "KEEP_TRYING" "PREQ_FAIL")))) + + + +;;;; kill megatests and dashboards in this area running on this host +(define (kill-mtest-dboard) + + (let* ((this-toppath (pid->cwd (current-process-id))) + (tmppath (toppath->tmppath this-toppath)) + (config (let ((res (conc this-toppath "/megatest.config"))) + (when (not (file-exists? res)) + (ierr "This is not a megatest run area; "res" does not exist. Aborting.") + (exit 2)) + res)) + (mtest-procs (get-my-mtest-procs)) + (dashboard-procs (get-my-dashboard-procs)) + (all-pids (map proc-PID (append mtest-procs dashboard-procs))) + (our-pids (filter (lambda (pid) + ;;(print (pid-COMMAND pid)) + (and + (equal? (pid->cwd pid) this-toppath) + + )) + all-pids))) + + (if (null? our-pids) + (inote "No mtest or dboard processes on this host in in this runarea.") + (begin + (iwarn "Killing all megatest and dashboard processes on this host.") + (gracefully-kill-pids our-pids))) + )) + + + +(define (db-mt-version dbpath) + (let* ((cmd (conc "sqlite3 "dbpath" 'select val from metadat where var=\"MEGATEST_VERSION\"'")) + (res (do-or-die cmd))) + res)) + +;; TODO +(define (db-islocked? dbpath) + (let-values (((ec so se) (isys (conc "sqlite3 "dbpath" vacuum")))) + (let* ((message se) + (is-locked (string-match "^.*database is locked.*$" message))) + (inote "dbfile - "dbpath "; message - "message) + is-locked))) + +(define (db-unlock dbpath) + (system (conc "/nfs/site/bjbarcla/bin/unlock_db.sh " dbpath)) + + ;; (let* ((temp-dbpath (conc "/tmp/"(get-environment-variable "USER")"-"(current-process-id)".db"))) + ;; (inote "Unlocking "dbpath) + ;; (do-or-die (conc "cp "dbpath" "temp-dbpath)) + ;; (do-or-die (conc "rm -f "dbpath)) + ;; (let* ((cmd (conc "sqlite3 "temp-dbpath" .dump | sqlite3 "dbpath))) + ;; (inote "Running: "cmd) + ;; (system cmd)) + ;; ;;(do-or-die "sqlite3 "temp-dbpath" .dump | sqlite3 "dbpath) + ;; (if (db-islocked? dbpath) + ;; (begin + ;; (ierr "Could not unlock "dbpath) + ;; (exit 5)) + ;; (inote "Unlocked "dbpath)) + ;; #t) + + ) + + +(define *user* (do-or-die "ls -ld . | awk '{print $3}'")) + +(define (false-on-exception thunk) + (handle-exceptions exn #f (thunk) )) + +(define (safe-file-exists? path-string) + (false-on-exception (lambda () (file-exists? path-string)))) + +(defstruct proc + (USER "") + (PID -1) + (%CPU -1.0) + (%MEM -1.0) + (VSZ -1) + (RSS -1) + (TTY "") + (STAT "") + (START "") + (TIME "") + (COMMAND "")) + +(define (toppath->tmppath toppath) + (let* ((user *user*) + (area (car (string-split + (car (reverse (string-split toppath "/"))) + "."))) + (dotified-path (string-substitute "/" "." toppath "all"))) + (conc "/tmp/" user "/megatest_localdb/" area "/" dotified-path))) + + +(define (delete-db dbfile) + (let* ((db-files (glob (conc dbfile "*")))) + (for-each + (lambda (file) + (inote "delete file " file) + (if (delete-file* file) + (inote "Removed file - " file) + (iwarn "Could Not Remove file - " file)) + ) + db-files))) + +(define (check-db dbfile) + (let* ((has-wal (safe-file-exists? (conc dbfile "-wal"))) + (has-shm (safe-file-exists? (conc dbfile "-shm"))) + (has-journal (safe-file-exists? (conc dbfile "-journal"))) + (has-db (safe-file-exists? dbfile)) + (ok-flag #t)) + (when has-journal + (iwarn "Journal exists - "(conc dbfile "-journal")) + ) + (when has-wal + (set! ok-flag #f) + (iwarn "Wal-mode db exists: "(conc dbfile "-wal"))) + (if (not has-db) + (begin + (inote "db does not exists " dbfile) + (set! ok-flag #f)) + (let* ((db-size (file-size dbfile))) + (inote "db size = " db-size " -- " dbfile) + (when (member db-size (list 0 1024)) + (iwarn "db has bad size - "db-size" -- "dbfile) + (set! ok-flag #f)))) + ok-flag)) + + +(define (linux-get-process-info-records) + (let* ((raw (do-or-die "/bin/ps auwx")) + (all-lines (string-split raw "\n")) + (lines (cdr all-lines)) ;; skip title lines + (re (regexp "^(\\S+)\\s+(\\d+)\\s+(\\S+)\\s+(\\S+)\\s+(\\S+)\\s+(\\S+)\\s+(\\S+)\\s+(\\S+)\\s+(\\S+)\\s+(\\S+)\\s+(.*)$"))) + (filter + proc? + (map + (lambda (line) + (let ((match (string-match re line))) + (if match + (make-proc + USER: (list-ref match 1) + PID: (string->number (list-ref match 2)) + %CPU: (string->number (list-ref match 3)) + %MEM: (string->number (list-ref match 4)) + VSZ: (string->number (list-ref match 5)) + RSS: (string->number (list-ref match 6)) + TTY: (string->number (list-ref match 7)) + STAT: (list-ref match 8) + START: (list-ref match 9) + TIME: (list-ref match 10) + COMMAND: (list-ref match 11)) + #f))) + lines)))) + +(define (get-my-mtest-server-procs) + (let* ((procs (linux-get-process-info-records)) + (my-mtest-procs + (filter + (lambda (a-proc) + (and + (equal? *user* (proc-USER a-proc)) + (string-match "^.*/mtest\\s+.*-server.*" (proc-COMMAND a-proc)))) + procs))) + my-mtest-procs)) + +(define (get-my-mtest-procs) + (let* ((procs (linux-get-process-info-records)) + (my-mtest-procs + (filter + (lambda (a-proc) + (and + (equal? *user* (proc-USER a-proc)) + (string-match "^.*/m(ega)?test .*" (proc-COMMAND a-proc)) + (not (string-match "^.*/mtest-repair.*" (proc-COMMAND a-proc))))) + procs))) + my-mtest-procs)) + +(define (get-my-dashboard-procs) + (let* ((procs (linux-get-process-info-records)) + (my-dboard-procs + (filter + (lambda (a-proc) + (and + (equal? *user* (proc-USER a-proc)) + (string-match "^.*/dboard.*" (proc-COMMAND a-proc)))) + procs))) + my-dboard-procs)) + + +(define (pid->environ-hash pid) + (let* ((envfile (conc "/proc/"pid"/environ")) + (ht (make-hash-table)) + (rawdata (with-input-from-file envfile read-string)) + (lines (string-split rawdata (make-string 1 #\nul )))) + (for-each + (lambda (line) + (let ((match (string-match "(^[^=]+)=(.*)" line))) + (if match + (hash-table-set! ht (list-ref match 1) (list-ref match 2))))) + lines) + ht)) + +(define (pid->cwd pid) + (read-symbolic-link (conc "/proc/"pid"/cwd"))) + +(define (pid->mtest-monitor-db-file pid #!key (megatest_exe "megatest")) + (let* ((env (pid->environ-hash pid)) + (ltdir (hash-table-ref/default env "MT_LINKTREE" #f)) + (radir (hash-table-ref/default env "MT_RUN_AREA_HOME" #f)) + (cwd (pid->cwd pid))) + (let ((res + (cond + (ltdir (conc ltdir "/.db/monitor.db")) + (radir (conc + (do-or-die + (conc megatest_exe " -start-dir "radir" -show-config -section setup -var linktree")) + "/.db/monitor.db")) + (cwd (conc + (do-or-die + (conc megatest_exe " -start-dir "cwd" -show-config -section setup -var linktree")) + "/.db/monitor.db")) + + (else #f)))) + res))) + + + + + +(define (get-mdb-status mdb-file pid) + ;; select state from servers where pid='4465'; + + (cond + ((not (string? mdb-file)) (conc "mdb-file could not be determined for pid " pid ">>"mdb-file )) + ((not (safe-file-exists? mdb-file)) (conc "mdb-file does not exist for pid "pid" : "mdb-file)) + (else + (let ((dbh (open-database mdb-file))) + + (set-busy-handler! dbh 10000) + (let* ((sql-str "select state from servers where pid=?;") + (stm (sql dbh sql-str)) + (alists (query fetch-alists stm (->string pid)))) + (if (null? alists) + "server pid not in monitor.db" + (cdr (car (car alists))))))))) + + +(define (mtest-server-pid->status pid) + (let* ((mdb-file (pid->mtest-monitor-db-file pid))) + (if mdb-file + (get-mdb-status mdb-file pid) + "no monitor.db file could be found" + ))) + + +(define (gracefully-kill-pids pids) + (for-each (lambda (pid) + (print "kill "pid) + (system (conc "kill "pid))) + pids) + (sleep 5) + (let* ((procs-left (linux-get-process-info-records)) + (pids-left (map proc-PID procs-left))) + (for-each (lambda (pid) + (when (member pid pids-left) + (print "kill -9"pid) + (system (conc "kill -9 "pid)))) + pids))) + + + +(define (kill pid) + (print "KILL "pid) + (do-or-die (conc "kill -9 "pid))) + +(define (reap-defunct-mtest-server-pid pid) + (let ((status (mtest-server-pid->status pid))) + (print pid"->"(mtest-server-pid->status pid)) + (if (member status (list "running" "dbprep" "available" "collision")) + (print "pid="pid" in status "status" -- not killing") + (kill pid)))) + +;; (let* ((procs (get-my-mtest-server-procs)) +;; (pids (map proc-PID procs)) +;; ) + +;; (for-each reap-defunct-mtest-server-pid pids)) + + + +(define (mtdbver->mtrelver mtdbver) + (let* ((table-alist '( + ("1.5402" . "1.54/02") + ("1.5406" . "1.54/05") + ("1.5408" . "1.54/07") + ("1.5409" . "1.54/09") + ("1.5412" . "1.54/12") + ("1.5413" . "1.54/13") + ("1.5414" . "1.54/14") + ("1.5415" . "1.54/15") + ("1.5416" . "1.54/16") + ("1.5417" . "1.54/17") + ("1.5418" . "1.54/18") + ("1.5419" . "1.54/19") + ("1.5421" . "1.54/21") + ("1.5411" . "1.54/support-for-skip") + ("1.5522" . "1.55/22") + ("1.5523" . "1.55/23") + ("1.5524" . "1.55/24") + ("1.5525" . "1.55/25") + ("1.6001" . "1.60/01") + ("1.6002" . "1.60/02") + ("1.6003" . "1.60/03") + ("1.6004" . "1.60/04") + ("1.6005" . "1.60/05") + ("1.6006" . "1.60/06") + ("1.6007" . "1.60/07") + ("1.6008" . "1.60/08") + ("1.6009" . "1.60/09") + ("1.6009" . "1.60/11") + ("1.6012" . "1.60/12") + ("1.6013" . "1.60/13") + ("1.6014" . "1.60/14") + ("1.6015" . "1.60/15") + ("1.6016" . "1.60/16") + ("1.6017" . "1.60/17") + ("1.6018" . "1.60/18") + ("1.6019" . "1.60/19") + ("1.6021" . "1.60/21") + ("1.6022" . "1.60/22") + ("1.6023" . "1.60/23") + ("1.6024" . "1.60/24") + ("1.6025" . "1.60/25") + ("1.6026" . "1.60/26") + ("1.6027" . "1.60/27") + ("1.6028" . "1.60/28") + ;;("1.6029" . "1.60/29") + ("1.6029" . "1.60/29a") + ("1.6031" . "1.60/31") + ("1.6101" . "1.61/01") + ("1.6101" . "1.61/01a") + ("1.6102-c2ba" . "1.61/02") + ("1.6103-3e88" . "1.61/03") + ("1.6104-ee53" . "1.61/04") + ("1.6105-232b" . "1.61/05") + ("1.6201-e652" . "1.62/01") + ("1.6204-c74d" . "1.62/04") + ("1.6205-aff0" . "1.62/05") + ("1.6207-6f59" . "1.62/07") + ("1.6301-fbf0" . "1.63/01") + ("1.6302-da4a" . "1.63/02") + ("1.6303-aa5f" . "1.63/03") + ("1.6304-fa49" . "1.63/04") + ("1.6305-a03b" . "1.63/05") + ("1.6306-7a12" . "1.63/06") + ("1.6307-fb5d" . "1.63/07") + ("1.6308-35e0" . "1.63/08") + ("1.6309-738c" . "1.63/09") + ("1.6309-880c" . "1.63/09a") + ("1.6309-b566" . "1.63/09b") + ("1.6311-fb43" . "1.63/11") + ("1.6311-fb43" . "1.63/11b") + ("1.6311-8a6c" . "1.63/11b") + ("1.6402-03c5" . "1.64/02") + ) + ) + (res (alist-ref mtdbver table-alist equal?))) + res)) + ADDED utils/wip/mtest-repair.scm Index: utils/wip/mtest-repair.scm ================================================================== --- /dev/null +++ utils/wip/mtest-repair.scm @@ -0,0 +1,139 @@ +#!/p/foundry/env/pkgs/chicken/4.10.0_ext/bin/csi -s + +(use chicken) +(use data-structures) + + +(include "/nfs/site/home/bjbarcla/bin2/mtest-repair-lib.scm") +(glib-color-mode 1) + +;;(define this-cmd (car (argv))) +(define this-cmd "/nfs/site/home/bjbarcla/bin2/mtest-repair.scm") + +;;; check mtver in xterm + +;; note - 11b is 1.6311-fb43 +(let ((mt-ver (do-or-die "megatest -version"))) + (when (member mt-ver '("1.6309-738c" "1.6029" "1.6309-b566")) + (iwarn "This xterm has an older version of megatest.") + (ierr "Please load latest megatest version to proceed.") + (print "eg.: source ../scripts/newrel-setup.csh 1.63/11b") + (exit 3))) + + +;;;; kill netbatch jobs from this megatest +;;(kill-mtest-dboard) +;;(system "/nfs/site/home/bjbarcla/bin2/mtest-nbstop.scm") + + +;;;; delete .homehost .homehost.config +;;;; if not on homehost, ssh homehost, cd here, killall mtest dboard +(when (file-exists? ".homehost.config") + (delete-db ".homehost.config")) + +(when (file-exists? ".homehost") + (let* ((homehost (with-input-from-file ".homehost" (lambda () (read))))) + (let* ((homehostname (do-or-die "host `cat .homehost` | sed 's/.$//' | awk '{print $NF}' | awk -F. '{print $1}'")) + (thishostname (get-environment-variable "HOST"))) + (when (not (equal? homehostname thishostname)) + (iwarn "Please also run this on the homehost -- "homehostname) + + (iwarn "eg: % ssh "homehostname" 'cd "(get-environment-variable "PWD")" && "this-cmd"'") + (print "") + (inote "sleeping for 5 seconds. hit ctrl-c now to run on homehost or wait to proceed.") + (sleep 5))))) + + + + + +(kill-mtest-dboard) + + +;;;; delete /tmp/.$USER-portlogger.db +(let ((plfile (conc "/tmp/."(get-environment-variable "USER") "-portlogger.db"))) + (when (safe-file-exists? plfile) + (inote "removing portlogger file") + (system (conc "rm "plfile)))) + + +;;;; move logs dir aside +(system (conc "mv logs logs-aside-`date +%s`")) +(system "mkdir logs") + +;;;; fixes for dependency diagram +(inote "Removing dep graph tmp files if they exist") +(system (conc "rm /tmp/."(get-environment-variable "USER")"-*.dot")) + +;;#ln -s /p/fdk/gwa/$USER/fossil/ext/_ext ext +(let* ((toppath (pid->cwd (current-process-id))) + (flow (car (string-split + (car (reverse (string-split toppath "/"))) + "."))) + (extdir (conc "/p/fdk/gwa/"(get-environment-variable "USER") + "/fossil/ext/"flow"_ext"))) + (when (and (safe-file-exists? extdir) + (not (safe-file-exists? "ext"))) + (inote "Linking in ext dir") + (system (conc "ln -s "extdir" ext")))) + + +;;;; check for 0 byte megatest{,_ref}.db in tmp. delete them +;;;; check for wal-mode megatest{,_ref}.db in tmp. delete them +(define (repair-dbs) + (let* ((this-toppath (pid->cwd (current-process-id))) + (tmppath (toppath->tmppath this-toppath)) + (golden-mtest-file (conc this-toppath "/megatest.db")) + (golden-mtest-file-ok (check-db "megatest.db")) + (tmp-mtest-file (conc tmppath "/megatest.db")) + (tmp-mtestref-file (conc tmppath "/megatest_ref.db")) + (tmp-mtest-file-ok (check-db tmp-mtest-file)) + (tmp-mtestref-file-ok (check-db tmp-mtestref-file)) + (alldbs (list tmp-mtest-file tmp-mtestref-file golden-mtest-file)) + ) +;;;; check for megatest{,_ref}.db in tmp that die on .schema. delete them + (when (safe-file-exists? tmppath) + (if tmp-mtest-file-ok + (inote "tmp megatest db file ok") + (delete-db tmp-mtest-file)) + (if tmp-mtestref-file-ok + (inote "tmp megatestref db file ok") + (delete-db tmp-mtestref-file))) + + ;;;;; check for locked dbs + (for-each (lambda (dbfile) + (let* ((locked (db-islocked? dbfile))) + (if (db-islocked? dbfile) + (begin + (iwarn "db locked - "dbfile) + (db-unlock dbfile)) + (inote "db not locked - "dbfile)))) + alldbs) + +;;;; check for megatest.db + (if golden-mtest-file-ok + (inote "golden megatest db file ok") + (if (not (file-exists? golden-mtest-file)) + (inote "megatest.db not present. Continuing.") + (begin + ;;;; if golden megatest db is broken, stop now! + (ierr "Golden megatest.db is broken. Please delete it or replace it from a backup version in .snapshot. If critical, contact env team to assist.") + (sendmail "bjbarcla" "!!Bad golden megatest.db" this-toppath) + (inote "Backups in .snapshot:") + (system "ls -l .snapshot/*/megatest.db") + (ierr "Not proceeding with any more checks.") + (exit 3)))) + )) + +;; TODO: check for and fix locked megatest.db and locked monitor.db (ritika working on) + + +(repair-dbs) + + + + + + + +

+ + This example is blank

Add some HTML KickStart Elements to see the magic happen

HTML KickStart

Ultra–Lean HTML5, CSS, & JS Building Blocksfor Rapid Website Production

Getting Started

Setup

Browsers

Notes

Buttons

Buttons

With Icons

Colors

Styles

Button Bar

Lists

Unordered List

Ordered List

UL.icons

UL.alt

Menus

Vertical Left

Horizontal

Vertical Right

Tables

Table (default)

Table.striped

Table.tight

Table.sortable

ToolTips

Tooltips

Tooltip Positions

Tooltips with HTML Content

HTML Content

Typography

Paragraphs

Blockquote

Blockquote Small

Inline Styles

Heading 1

Heading 2

Heading 3

Heading 4

Heading 5

Heading 6

Address

Horizontal Rules

HR

HR.alt1

HR.alt2

Icons/Glyphs

HTML KickStart now usingFont Awesome 4.2.0 Icons!

Code/Pre

PRE HTML

PRE CSS

PRE JS

Tabs

Tabs.left

Tabs.center

Tabs.right

Breadcrumbs

Breadcrumbs

Breadcrumbs.alt1

Grids/Columns

Responsive & Flexible Grid

Images

IMG.caption

DIV.gallery

IMG.align-left

IMG.align-right

IMG.full-width

Slideshow

Features

Forms

Form.vertical

Inline Form Fields (default)

Input/Label Sizes

Extras/Helpers

99Lime Announcements and Releases.

Paragraphs

Icon List

+
+ This example is blank

Ultra–Lean HTML5, CSS, & JS Building Blocks
for Rapid Website Production

HTML KickStart now using
Font Awesome 4.2.0 Icons!