// Scilab ( http://www.scilab.org/ ) - This file is part of Scilab
// Copyright (C) 2008 - INRIA - Serge STEER <serge.steer@inria.fr>
//
// This file must be used under the terms of the CeCILL.
// This source file is licensed as described in the file COPYING, which
// you should have received as part of this distribution.  The terms
// are also available at
// http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt

function extract_help_examples(dirpaths)

    // given a vector of strings giving help  chapter paths, or nothinf for
    // the default scilab help chapter paths,
    // this function build in SCI/tests/Examples the files required for
    // testing the examples given in all  xml help files available in the
    // given paths.

    global %helps
    global %helps_modules
    if %helps_modules == [] then
        moduleslist = getmodules();
        for i = 1:size(moduleslist,"*")
            add_module_help_chapter(moduleslist(i));
        end
    end
    %HELPS=[%helps_modules;%helps];

    logfile=mopen("extract_help_examples.log","w")
    lsave=lines();lines(0)
    if argn(2)<1 then
        dirpaths=%HELPS(:,1)';
    end
    for d=dirpaths
        helppaths=listfiles(pathconvert(d+"/*.xml",%f,%t))';
        mfprintf(logfile,"\nExtracting examples from "+d+"\n");
        mprintf("\n-- Extracting examples from "+d+"\n");
        count=0
        for h=helppaths
            mprintf(h+"\n")
            build_example_test(h,logfile)
        end
        mfprintf(logfile,"\n")
        mprintf("\n")
    end
    lines(lsave(2))
    mclose(logfile)

endfunction



function build_example_test(xml_path,logfile)

    // given the path of an xml help file
    // this function build in SCI/tests/Examples the files required for
    // testing the examples given in the xml help file

    name=basename(xml_path)
    if argn(2)<2 then logfile=mopen(name+".log","w"),end

    T=extract_help_example(xml_path); //look for examples

    if T<>[] then //an example is given
        t=gettesttype(T) //check if it includes interactive or graphic functions
        gen_test_files(T,name,t);
    end

endfunction




function t=gettesttype(T)

    interactive=["%io(1)","mscanf","dialog","tk","message","getcolor", ...
    "xset()","xclick","xgetmouse", "locate","edit", ...
    "x_choices","x_matrix","show_graph","addmenu","delmenu",..
    "uicontrol","uimenu","showprofile","editor","emacs","setbpt",..
    "eventhandler","dragrect","rubber","getfile","getvalue",...
    "portrait","plotprofile","getfont","getmark","getlinestyle"]

    graphics=["plot","pie","bar","mesh","barh","xrect","xstring","xarc","xfarc","xpoly","xfpoly","xarrow", ...
    "xset(", "xget(","contour","bode","black","nyquist","evans", ...
    "param3d","champ(","surf","gcf(","gca(", "gce(", "champ1", "drawaxis",..
    "xgraduate","glue","polar","mapsound"]

    //deff('foo',T)
    //T=primitives('foo')

    if grep(T,interactive)<>[] then
        t="i"
    elseif grep(T,graphics)<>[] then
        t="g"
    else
        t=""
    end

endfunction




function T=extract_help_example(h)

    //extract the example out of an xml help file

    if name=="man" then T=[],return,end
    T=mgetl(h);
    [row,which]=grep(T,["<EXAMPLE>","</EXAMPLE>"]);
    if row<>[] then
        if size(row,"*")==1 then row=[row row],end
        T=T(row(1):row(2));
        T(1)=stripblanks(strsubst(T(1),"<EXAMPLE>",""));
        T($)=stripblanks(strsubst(T($),"</EXAMPLE>",""));
        if length(T(1))==0 then T(1)=[];end
        if length(T($))==0 then T($)=[];end
        if T<>[] then
            T(1)=stripblanks(strsubst(T(1),"<![CDATA[",""));
            T($)=stripblanks(strsubst(T($),"]]>",""));
            if length(T(1))==0 then T(1)=[];end
            if length(T($))==0 then T($)=[];end
        end
    else
        T=[]
    end

endfunction



function gen_test_files(instructions,name,t)

    //set output directory

    select t
    case "i" then
        test_path="SCI/tests/interactive_tests/"
    case "g"
        test_path="SCI/tests/graphical_tests/"
    else
        test_path="SCI/tests/automatic_tests/"
    end

    //set file names
    tst=pathconvert(test_path+name+".tst",%f,%f)
    ref=pathconvert(test_path+name+"_data.ref",%f,%f)
    dia=strsubst(tst,".tst",".dia")

    interactive=t=="i"

    info=fileinfo(tst)//to check if the .tst file exists

    generate_dataref=%f;generate_tst=%f;
    if info==[] //no <name>.tst file exists
        mfprintf(logfile,"\n New Example "+name+"  the reference is built. Check\n")
        generate_tst=%t
        if ~interactive then
            generate_dataref=%t
            T=instrument_instruction("cmp",instructions,ref);
        end
    else
        // a tst file exists, check for validity
        //compare it with instructions
        T=instrument_instruction("cmp",instructions,ref);
        if newest(tst,xml_path)==1 then
            if fileinfo(ref)==[]&(~interactive) then
                mfprintf(logfile,"\n Example in "+name+"_data.ref no more exist, It is regenerated\n")
                generate_dataref=%t
            end
        else
            T1=mgetl(tst);
            if or(T1<>T) then
                mfprintf(logfile,"\n Example in "+name+" help file has changed, the reference is updated. Check\n")
                generate_tst=%t
                generate_dataref=%t
            elseif fileinfo(ref)==[]&(~interactive) then
                mfprintf(logfile,"\n Example in "+name+"_data.ref no more exist, It is regenerated\n")
                generate_dataref=%t
            end
        end
    end

    if generate_dataref&(~interactive) then

        //build the reference data

        Tb=instrument_instruction("build",instructions,ref);
        build_reference_data(Tb)

        [x,ierr]=fileinfo(ref)
        if x(1)==0 then mfprintf(logfile,"generated file: "+name+"_data.ref is Empty "),end
    end

    if generate_tst then
        // write down the test script
        mputl(T,tst),
        //remove the <name>.dia file
        if fileinfo(dia)<>[] then deletefile(pathconvert(dia,%f,%t)); end
        dia=dia+".ref"
        //remove the <name>.dia.ref file
        if fileinfo(dia)<>[] then deletefile(pathconvert(dia,%f,%t)); end
    end

endfunction



function build_reference_data(instructions)

    mputl(instructions,TMPDIR+"/temp.tst")

    // Execute the temporary file to generate the data reference file
    if execstr("exec(TMPDIR+''/temp.tst'',-1)","errcatch")<>0 then
        mclose(%U)
    end

endfunction



function instructions=instrument_instruction(job,instructions,refpath)

    //Author : Serge Steer, april 2005, Copyright INRIA
    //
    //Executes the given instructions saving all the intermediate
    // results into a Scilab  binary file.
    // This function must mirror the  run_with_ref one.

    if argn(2)<>3 then error(42),end
    // Form a function with the given instructions
    mputl(["function %test()";instructions;"xdel(winsid());";"endfunction"],TMPDIR+"/test.sci")
    // Compile and load it
    //use exec instead of getf to handle inline functions definition
    exec(TMPDIR+"/test.sci",-1);
    // Get the pseudo-code image

    l1=macr2lst(%test)

    // Adapt the  pseudo-code to add build or run tools
    if job=="build" then
        l=add_ref_code(list(l1(5:$)));
    else //run
        l=add_cmp_code(list(l1(5:$)));
    end
    l=list(l(1:$-2));

    // Generate the Scilab instructions from the modified pseudo-code
    txt=pseudocode2text(l)

    // Add opening and closing instructions
    instructions=[]
    if job<>"build" then instructions="getf SCI/util/testexamples.sci",end
    instructions=[instructions;"reinit_for_test()"];
    if job=="build" then
        instructions=[instructions;"%U=mopen(''"+refpath+"'',''wb'');"]
    else
        instructions=[instructions;"%U=mopen(''"+refpath+"'',''rb'');"]
    end
    instructions=[instructions; txt;"mclose(%U);"];

endfunction



function p=primitives(mac_name,p)

    //search for the  primitives called by a given macro, the second arg is
    //for recursive calls only

    funcprot(0)
    global scanned_macros

    if argn(2)==1  then p=[],scanned_macros=[];end
    ierr=execstr("vars=macrovar("+mac_name+")","errcatch")
    if ierr<>0 then return,end
    called=vars(4);nc=size(called,1)
    if nc==0 then p=[],return,end
    to_get=[]
    for k=1:nc
        if find(called(k)==scanned_macros)<>[] then
            to_get=[to_get,%f];
        else
            to_get=[to_get,%t];
        end
    end
    called=called(to_get)
    nc=size(called,"*")
    for k=1:nc
        clear w
        execstr("w="+called(k))
        if type(w)==130 then
            if grep(p,called(k))==[] then p=[p called(k)],end
        else
            scanned_macros=[scanned_macros called(k)]
            p=primitives(called(k),p)
        end
    end

endfunction


function txt=pseudocode2text(p)

    //Author : Serge Steer, april 2005, Copyright INRIA
    //
    //Generate Scilab instructions corresponding to the pseudo-code

    //make ins2sci known
    prot=funcprot();funcprot(0);fun2string=fun2string;funcprot(prot);
    //initialize variables for it
    lcount=1;level=[0,0];
    quote="''"
    dquote=""""
    CR="\@"
    opstable()
    txt=ins2sci(mmodlst(p),1)
endfunction



function ln=add_ref_code(l)

    //Author : Serge Steer, april 2005, Copyright INRIA
    //
    //Given a  pseudo-code  this function add code after each affectation
    //operation (29) to save lhs variables into a binary file

    ln=list()// initialize result pseudo-code image
    for k=1:size(l) //loop on pseudo-codes
        lk=l(k);
        if type(lk)==10 then //regular pseudo-code

            if lk(1)=="29" then //affectation operation
                if and(lk(2)<>["52" "43" "99"]) then lk(2)="52",end

                if or(lk(2)==["52"  "99"]) then

                    //display required build reference
                    lk(2)="43" //disable display
                    if lk(3)=="ans" then
                        if and(l(k-1)==["5","25","1","1"])&l(k-2)(1)=="2" then
                            vv=l(k-2)(2)
                            lk(3)=l(k-2)(2)
                            if exists(vv)==1 then
                                execstr("var="+vv)
                                if exists(vv)==1&or(type(var)==[11 13 130]) then
                                    //name is a function, syntax is equivalent to ans=name()
                                    lk(3)="%ans";
                                end
                            end
                        elseif and(l(k-1)==["20","deff","2","1"]) then
                            ln($+1)=lk
                            continue
                        else
                            lk(3)="%ans";
                        end
                    end

                    ln($+1)=lk

                    for i=3:2:size(lk,"*")
                        ln($+1)="15" //newline
                        name=lk(i);ref=name+"_ref"
                        // add instruction: save_ref('''+name+''');
                        //
                        ln($+1)=["3",name];
                        ln($+1)=["2","save_ref","-2","1"];
                        ln($+1)=["5","25","2","1"];
                        ln($+1)=["29","43","ans","0"];
                    end

                    ln($+1)="15";
                else
                    ln($+1)=lk
                end

            elseif  lk(1)=="2"&or(lk(2)==["xdel","clf"]) then
                //change some function names to allow overloading
                lk(2)=lk(2)+"_build"
                ln($+1)=lk

            else //other operations, just copy them
                ln($+1)=lk
            end

        elseif type(lk)==15 then //control structure starts
            lt=lk(1)
            //call the add_ref_code function recursively for imbedded instructions
            if or(lt(1)==["if","while"]) then
                lnk=list(lk(1),lk(2))
                for i=3:size(lk), lnk($+1)=add_ref_code(lk(i));end
                ln($+1)=lnk
            elseif lt(1)=="for" then
                ln($+1)=list(lk(1),lk(2),add_ref_code(lk(3)))
            elseif lt(1)=="select" then
                lnk=list(lk(1),lk(2))
                for i=3:2:size(lk)-1 //the "case" sequence
                    lnk($+1)=lk(i)
                    lnk($+1)=add_ref_code(lk(i+1));
                end
                //the else
                if i+2==size(lk) then lnk($+1)=add_ref_code(lk(i+2));end
                ln($+1)=lnk
            end
        end
    end
endfunction



function ln=add_cmp_code(l)

    //Author : Serge Steer, april 2005, Copyright INRIA
    //
    //Given a  pseudo-code  this function add code after each affectation
    //operation (29) to compare lhs variables with references given in  a binary file
    // This function must mirror the  add_ref_code one

    ln=list() // initialize result pseudo-code image
    for k=1:size(l) //loop on pseudo-codes
        lk=l(k);
        if type(lk)==10 then //regular pseudo-code
            if lk(1)=="29" then //affectation operation
                if and(lk(2)<>["52" "43" "99"]) then lk(2)="52",end
                if or(lk(2)==["52"  "99"]) then
                    //display required compare result with reference
                    lk(2)="43"// disable display
                    if lk(3)=="ans" then
                        if and(l(k-1)==["5","25","1","1"])&l(k-2)(1)=="2" then
                            vv=l(k-2)(2)
                            lk(3)=l(k-2)(2)
                            if exists(vv)==1 then
                                execstr("var="+vv)
                                if exists(vv)==1&or(type(var)==[11 13 130]) then
                                    //name is a function, syntax is equivalent to ans=name()
                                    lk(3)="%ans";
                                end
                            end
                        elseif and(l(k-1)==["20","deff","2","1"]) then
                            ln($+1)=lk
                            continue
                        else
                            lk(3)="%ans";
                        end
                    end

                    ln($+1)=lk

                    for i=3:2:size(lk,"*")
                        ln($+1)="15"//newline
                        name=lk(i);ref=name+"_ref";
                        // add instruction: if load_ref('''+name+''') then pause;end
                        ln($+1)=list("if",list(["3",name],["2","load_ref","-2","1"],["5","25","2","1"]),..
                        list("12"),list())
                    end

                    ln($+1)="15"
                else
                    ln($+1)=lk
                end
            elseif  lk(1)=="2"&or(lk(2)==["xdel","clf"]) then
                //change some function names to allow overloading
                lk(2)=lk(2)+"_run"
                ln($+1)=lk
            else //other operations, just copy them
                ln($+1)=lk
            end
        elseif type(lk)==15 then  //control structure starts
            lt=lk(1)
            //call the add_ref_code function recursively for imbedded instructions
            if or(lt(1)==["if","while"]) then
                lnk=list(lk(1),lk(2))
                for i=3:size(lk), lnk($+1)=add_cmp_code(lk(i));end
                ln($+1)=lnk
            elseif lt(1)=="for" then
                ln($+1)=list(lk(1),lk(2),add_cmp_code(lk(3)))
            elseif lt(1)=="select" then
                lnk=list(lk(1),lk(2))
                for i=3:2:size(lk)-1 //the "case" sequence
                    lnk($+1)=lk(i)
                    lnk($+1)=add_cmp_code(lk(i+1));
                end
                //the else
                if i+2==size(lk) then lnk($+1)=add_cmp_code(lk(i+2));end
                ln($+1)=lnk
            end
        end
    end

endfunction



function r=xbasc_build(w)

    //Author : Serge Steer, april 2005, Copyright INRIA
    //
    //Save the graphic windows to be cleared in  a Scilab  binary file.
    // This function must mirror the  xbasc_run one.

    r=%f
    if winsid()==[] then return,end
    cur=xget("window")
    //
    if argn(2)==1 then
        ids_ref=[]

        for k=1:size(w,"*")
            xset("window",w(k))
            if get("figure_style")=="new" then ids_ref=[ids_ref,w(k)],end
        end

        save(%U,ids_ref)

        for k=ids_ref
            %wins_ref=ghdl2tree(scf(k));save(%U,%wins_ref);
        end

        clf(w)
    else
        if get("figure_style")=="old" then return,end
        ids_ref=xget("window");
        save(%U,ids_ref)
        %wins_ref=ghdl2tree(gcf());
        save(%U,%wins_ref)
        clf()
    end
    if or(winsid()==cur) then xset("window",cur),end

endfunction



function r=xbasc_run(w)

    //Author : Serge Steer, april 2005, Copyright INRIA
    //
    //Compare the graphic windows to be cleared with the reference givenin  a Scilab  binary file.
    // This function must mirror the  xbasc_build one.

    r=%f
    if winsid()==[] then return,end
    cur=xget("window")
    //
    if argn(2)==1 then
        ids_=[]
        for k=1:size(w,"*")
            xset("window",w(k))
            if get("figure_style")=="new" then ids_=[ids_,w(k)],end
        end
        load(%U,"ids_ref")
        if or(ids_ref<>ids_) then r=%t,return,end
        for k=ids_ref
            %wins_=ghdl2tree(scf(k));
            load(%U,"%wins_ref");
            if %CMP(%wins_, %wins_ref) then r=%t,return,end
        end
        clf(w)
    else
        if get("figure_style")=="old" then return,end
        ids_=xget("window");
        load(%U,"ids_ref")
        if or(ids_ref<>ids_) then r=%t,return,end
        %wins_=ghdl2tree(gcf());
        load(%U,"%wins_ref");
        if %CMP(%wins_, %wins_ref) then r=%t,return,end
        clf()
    end
    if or(winsid()==cur) then xset("window",cur),end

endfunction



function r=clf_build(w,opt)

    //Author : Serge Steer, april 2005, Copyright INRIA
    //
    //Save the graphic windows to be cleared in  a Scilab  binary file.
    // This function must mirror the  clf_run one.

    r=%f
    if winsid()==[] then return,end
    cur=xget("window")
    rhs=argn(2)
    if rhs==1&type(w)==10 then opt=w;rhs=0,end
    if winsid()==[] then return,end
    //
    if rhs>=1 then
        ids_ref=[]
        if type(w)==9 then
            H=w;w=[]
            for h=H,w=[w,h.figure_id],end
        end
        for k=1:size(w,"*")
            xset("window",w(k))
            if get("figure_style")=="new" then ids_ref=[ids_ref,w(k)],end
        end
        save(%U,ids_ref)
        for k=ids_ref,%wins_ref=ghdl2tree(scf(k));save(%U,%wins_ref);end
        if rhs==1 then clf(w),else clf(w,opt),end
    else
        if get("figure_style")=="old" then return,end
        ids_ref=xget("window");
        save(%U,ids_ref)
        %wins_ref=ghdl2tree(gcf());
        save(%U,%wins_ref)
        clf()
    end
    if or(winsid()==cur) then xset("window",cur),end

endfunction



function r=clf_run(w,opt)

    //Author : Serge Steer, april 2005, Copyright INRIA
    //
    //Compare the graphic windows to be cleared with the reference givenin  a Scilab  binary file.
    // This function must mirror the  clf_build one.

    r=%f
    if winsid()==[] then return,end
    cur=xget("window")
    rhs=argn(2)
    if rhs==1&type(w)==10 then opt=w;rhs=0,end
    if winsid()==[] then return,end
    //
    if rhs==1 then
        ids_=[]
        if type(w)==9 then
            H=w;w=[]
            for h=H,w=[w,h.figure_id],end
        end
        for k=1:size(w,"*")
            xset("window",w(k))
            if get("figure_style")=="new" then ids_=[ids_,w(k)],end
        end
        load(%U,"ids_ref")
        if or(ids_ref<>ids_) then r=%t,return,end
        for k=ids_ref
            %wins_=ghdl2tree(scf(k));
            load(%U,"%wins_ref");
            if %CMP(%wins_, %wins_ref) then r=%t,return,end
        end
        if rhs==1 then clf(w),else clf(w,opt),end
    else
        if get("figure_style")=="old" then return,end
        ids_=xget("window")
        load(%U,"ids_ref")
        if or(ids_ref<>ids_) then r=%t,return,end
        %wins_=ghdl2tree(gcf());
        load(%U,"%wins_ref");
        if %CMP(%wins_,%wins_ref) then r=%t,return,end
        clf()
    end
    if or(winsid()==cur) then xset("window",cur),end

endfunction



function r=xdel_build(w)

    //Author : Serge Steer, april 2005, Copyright INRIA
    //
    //Save the graphic windows to be cleared in  a Scilab  binary file.
    // This function must mirror the  xdel_run one.

    r=%f
    if winsid()==[] then return,end
    cur=xget("window")
    //
    if argn(2)>=1 then
        ids_ref=[]
        for k=1:size(w,"*")
            xset("window",w(k))
            if get("figure_style")=="new" then ids_ref=[ids_ref,w(k)],end
        end
        save(%U,ids_ref)
        for k=ids_ref,%wins_ref=ghdl2tree(scf(k));save(%U,%wins_ref);end
        xdel(w);
    else
        if get("figure_style")=="old" then return,end
        ids_ref=xget("window");
        save(%U,ids_ref)
        %wins_ref=ghdl2tree(gcf());
        save(%U,%wins_ref)
        xdel()
    end
    if or(winsid()==cur) then xset("window",cur),end

endfunction



function r=xdel_run(w,opt)

    //Author : Serge Steer, april 2005, Copyright INRIA
    //
    //Compare the graphic windows to be cleared with the reference givenin  a Scilab  binary file.
    // This function must mirror the  xdel_build one.

    r=%f
    if winsid()==[] then return,end
    cur=xget("window")
    //
    if argn(2)==1 then
        ids_=[]
        for k=1:size(w,"*")
            xset("window",w(k))
            if get("figure_style")=="new" then ids_=[ids_,w(k)],end
        end
        load(%U,"ids_ref")
        if or(ids_ref<>ids_) then r=%t,return,end
        for k=ids_ref
            %wins_=ghdl2tree(scf(k));
            load(%U,"%wins_ref");
            if %CMP(%wins_, %wins_ref) then r=%t,return,end
        end
        xdel(w)
    else
        if get("figure_style")=="old" then return,end
        ids_=xget("window")
        load(%U,"ids_ref")
        if or(ids_ref<>ids_) then r=%t,return,end
        %wins_=ghdl2tree(gcf());
        load(%U,"%wins_ref");
        if %CMP(%wins_,%wins_ref) then r=%t,return,end
        xdel()
    end
    if or(winsid()==cur) then xset("window",cur),end

endfunction



function save_ref(name)

    if exists(name)==0 then return,end
    v=evstr(name)
    if type(v) == 9 then   v = ghdl2tree(v);end,
    if type(v) == 128 then   v = 128;end,// lu handle
    execstr(name+"_ref=v;save(%U,"+name+"_ref"+")")

endfunction



function r=load_ref(name)
    if exists(name)==0 then r=%f;return,end
    v=evstr(name)
    if type(v) == 9 then   v = ghdl2tree(v);end,
    execstr(name+"_ref=v;load(%U,"+name+"_ref"+");r=%CMP(v,"+name+"_ref);")
endfunction



function reinit_for_test()

    //reinitialize some Scilab state to be able to reproduce the same tests

    sdf();sda()
    xdel(winsid())
    grand("setgen","clcg4");grand("setall",11111111,22222222,33333333,44444444);
    grand("setgen","kiss");grand("setsd",362436069,521288629,123456789,380116160);
    grand("setgen","clcg2");grand("setsd",1234567890,123456789);
    grand("setgen","urand");grand("setsd",0);
    grand("setgen","fsultra");grand("setsd",1234567,7654321);
    grand("setgen","mt");grand("setsd",5489);
    rand("seed",0);

    clearglobal()
    format("v",10)

endfunction