From 9d24b488add8b4c7c689f58a095184a6ed85e9f1 Mon Sep 17 00:00:00 2001 From: wtschueller Date: Tue, 17 Jun 2014 21:50:40 +0200 Subject: Tcl: support eval/catch commands --HG-- extra : rebase_source : 5d7e3a2b3c549419c672cddd8d780542053d68bb --- src/tclscanner.l | 51 ++++++++- testing/059/059__command__catch_8tcl.xml | 191 +++++++++++++++++++++++++++++++ testing/059_command_catch.tcl | 87 ++++++++++++++ 3 files changed, 327 insertions(+), 2 deletions(-) create mode 100644 testing/059/059__command__catch_8tcl.xml create mode 100644 testing/059_command_catch.tcl diff --git a/src/tclscanner.l b/src/tclscanner.l index 48e8214..0f35122 100644 --- a/src/tclscanner.l +++ b/src/tclscanner.l @@ -1817,6 +1817,42 @@ static tcl_scan *tcl_command_ARG(tcl_scan *myScan, unsigned int i, bool ignoreOu } //! Handle internal tcl commands. +// "eval arg ?arg ...?" +static void tcl_command_EVAL() +{ +D + tcl_codify_cmd("keyword", 0); + tcl_scan *myScan = tcl.scan.at(0); + QCString myString = ""; + // we simply rescan the line without the eval + // we include leading whitespace because tcl_scan_start will examine + // the first char. If it finds a bracket it will assume one expression in brackets. + // Example: eval [list set] [list NotInvoked] [Invoked NotInvoked] + for (unsigned int i = 1; i < tcl.list_commandwords.count(); i++) + { + myString += (*tcl.list_commandwords.at(i)).utf8(); + } + myScan = tcl_scan_start('?', myString, + myScan->ns, myScan->entry_cl, myScan->entry_fn); +} + +//! Handle internal tcl commands. +// "catch script ?resultVarName? ?optionsVarName?" +static void tcl_command_CATCH() +{ +D + tcl_codify_cmd("keyword", 0); + tcl_codify_cmd(NULL, 1); + tcl_scan *myScan = tcl.scan.at(0); + myScan = tcl_scan_start('?', *tcl.list_commandwords.at(2), + myScan->ns, myScan->entry_cl, myScan->entry_fn); + for (unsigned int i = 3; i < tcl.list_commandwords.count(); i++) + { + myScan = tcl_command_ARG(myScan, i, false); + } +} + +//! Handle internal tcl commands. // "if expr1 ?then? body1 elseif expr2 ?then? body2 elseif ... ?else? ?bodyN?" static void tcl_command_IF(QStringList type) { @@ -2458,9 +2494,20 @@ tcl_inf("->\n"); } /* * Start of internal tcl keywords - * Ready: if, for, foreach, while - * TODO: switch, eval, ? + * Ready: eval, catch, if, for, foreach, while */ + if (myStr=="eval") + { + if (tcl.list_commandwords.count() < 3) {myLine=__LINE__;goto command_warn;} + tcl_command_EVAL(); + goto command_end; + } + if (myStr=="catch") + { + if (tcl.list_commandwords.count() < 3) {myLine=__LINE__;goto command_warn;} + tcl_command_CATCH(); + goto command_end; + } if (myStr=="for") { if (tcl.list_commandwords.count() != 9) {myLine=__LINE__;goto command_warn;} diff --git a/testing/059/059__command__catch_8tcl.xml b/testing/059/059__command__catch_8tcl.xml new file mode 100644 index 0000000..6604413 --- /dev/null +++ b/testing/059/059__command__catch_8tcl.xml @@ -0,0 +1,191 @@ + + + + 059_command_catch.tcl + + + + Invoked + args + Invoked + + should be reference by every proc below + + + + + + + a + b + c + d + e + f + g + h + i + j + + + + NotInvoked + args + NotInvoked + + must not be reference by every proc below + + + + + + + + + + a + args + a + + + + + + + + Invoked + + + + b + args + b + + + + + + + + Invoked + + + + c + args + c + + + + + + + + Invoked + + + + d + args + d + + + + + + + + Invoked + + + + e + args + e + + + + + + + + Invoked + + + + f + args + f + + + + + + + + Invoked + + + + g + args + g + + + + + + + + Invoked + + + + h + args + h + + + + + + + + Invoked + + + + i + args + i + + + + + + + + Invoked + + + + j + args + j + + + + + + + + Invoked + + + + + + + + + diff --git a/testing/059_command_catch.tcl b/testing/059_command_catch.tcl new file mode 100644 index 0000000..4227da7 --- /dev/null +++ b/testing/059_command_catch.tcl @@ -0,0 +1,87 @@ +#// objective: tests processing of catch/eval, only references/referencedby relations are relevant +#// check: 059__command__catch_8tcl.xml +#// config: REFERENCED_BY_RELATION = yes +#// config: REFERENCES_RELATION = yes +#// config: EXTRACT_ALL = yes +#// config: INLINE_SOURCES = no + +## +# \brief should be reference by every proc below +proc Invoked args { + puts "Procedure \"Invoked\" is invoked indeed. Ok." + return $args +} +## +# \brief must not be reference by every proc below +proc NotInvoked args { + puts "Procedure \"NotInvoked\" is invoked. Not Ok!" + return $args +} +# +# check if call references work at all +proc a args { + Invoked NotInvoked + return +} +# +# catch command +# Tcl8.5: catch script ?resultVarName? ?optionsVarName? +proc b args { + catch Invoked + return +} +proc c args { + catch Invoked NotInvoked + return +} +proc d args { + catch Invoked NotInvoked NotInvoked + return +} +proc e args { + set r [catch Invoked NotInvoked NotInvoked] + return +} +proc f args { + set r [catch {Invoked} NotInvoked NotInvoked] + return +} +proc g args { + set r [catch { + set x [Invoked] + } NotInvoked NotInvoked] + return +} +# eval arg ?arg ...? +proc h args { + eval Invoked NotInvoked + return +} +proc i args { + eval set NotInvoked [Invoked NotInvoked] + return +} +# This is a striped down example. Original: +# +# jpeg.tcl -- +# +# Querying and modifying JPEG image files. +# +# Copyright (c) 2004 Aaron Faupell +# +# ... +# eval [list addComment $file] [lreplace $com 0 0 $comment] +# ... +proc j args { + eval [list set] [list NotInvoked] [Invoked NotInvoked] + return +} +# +# call all single letter procs +# let tcl check what is called and what is not called +foreach p [info procs ?] { + puts "Check procedure \"$p\"" + $p +} +exit + -- cgit v0.12 From 2984dad86558b4a81e11ce07485057e3903a9304 Mon Sep 17 00:00:00 2001 From: wtschueller Date: Wed, 18 Jun 2014 21:37:44 +0200 Subject: Tcl: support switch command --HG-- extra : rebase_source : f516669986006db5aca6af6417f323e57fa848d1 --- src/tclscanner.l | 183 ++++++++++++++- testing/060/060__command__switch_8tcl.xml | 358 ++++++++++++++++++++++++++++++ testing/060_command_switch.tcl | 238 ++++++++++++++++++++ 3 files changed, 778 insertions(+), 1 deletion(-) create mode 100644 testing/060/060__command__switch_8tcl.xml create mode 100644 testing/060_command_switch.tcl diff --git a/src/tclscanner.l b/src/tclscanner.l index 0f35122..f9878db 100644 --- a/src/tclscanner.l +++ b/src/tclscanner.l @@ -1837,6 +1837,181 @@ D } //! Handle internal tcl commands. +// switch ?options? string pattern body ?pattern body ...? +// switch ?options? string {pattern body ?pattern body ...?} +static void tcl_command_SWITCH() +{ +D + tcl_codify_cmd("keyword",0); + tcl_codify_cmd(NULL,1); + tcl_scan *myScan=NULL; + unsigned int i; + QCString token; + // first: find the last option token + unsigned int lastOptionIndex = 0; + for (i = 2; iafter << "NULL" << QCString("{"); + } + else + { + tcl_codify(NULL,QCString("{")); + } + } + // ToDo: check if multibyte chars are handled correctly + while (token.length() > 0) + { + TclFindElement((const char*)token, token.length(), &elem, &next, &size, NULL); + //printf("%s\nstart=%d, elem=%d, next=%d, size=%d, brace=%d\n", + // (const char*) token, (const char*) token, elem, next, size, brace); + // + // handle leading whitespace/opening brace/double quotes + if (elem - token > 0) + { + if (myScan != NULL) + { + myScan->after << "NULL" << token.left(elem - token); + } + else + { + tcl_codify(NULL, token.left(elem - token)); + } + } + // handle actual element without braces/double quotes + if (nextIsPattern) + { + if (myScan != NULL) + { + myScan->after << "NULL" << token.mid(elem - token,size); + } + else + { + tcl_codify(NULL,token.mid(elem - token, size)); + } + //printf("pattern=%s\n",(const char*) token.mid(elem - token, size)); + } + else { + if (myScan != NULL) + { + myScan->after << "script" << token.mid(elem - token, size); + } + else + { + myScan = tcl.scan.at(0); + myScan = tcl_scan_start('?', token.mid(elem - token, size), + myScan->ns, myScan->entry_cl, myScan->entry_fn); + } + //printf("script =%s\n", (const char*) token.mid(elem - token, size)); + } + // handle trailing whitespace/closing brace/double quotes + if (next - elem - size > 0) + { + if (myScan != NULL) + { + myScan->after << "NULL" << token.mid(elem - token + size, next - elem - size); + } + else + { + tcl_codify(NULL, token.mid(elem - token + size, next - elem - size)); + } + } + nextIsPattern = !nextIsPattern; + token = token.mid(next - token); + } + if (inBraces) + { + if (myScan != NULL) + { + myScan->after << "NULL" << QCString("}"); + } + else + { + tcl_codify(NULL, QCString("}")); + } + } + if (!nextIsPattern) + { + tcl_war("Invalid switch syntax: last token is not a list of even elements.\n"); + //tcl_war("%s\n", tcl.list_commandwords.join(" ").ascii()); + } + } + else if ((tcl.list_commandwords.count() - lastOptionIndex > 6) && + ((tcl.list_commandwords.count() - lastOptionIndex-3) % 4 == 0)) + { + //printf("detected: switch ?options? string pattern body ?pattern body ...?\n"); + myScan = tcl_command_ARG(myScan, lastOptionIndex + 1, false); + myScan = tcl_command_ARG(myScan, lastOptionIndex + 2, false); + //printf("value=%s\n",(const char*) (*tcl.list_commandwords.at(lastOptionIndex + 2)).utf8()); + for (i = lastOptionIndex + 3; i < tcl.list_commandwords.count(); i += 4) + { + myScan = tcl_command_ARG(myScan, i + 0, false); // whitespace + myScan = tcl_command_ARG(myScan, i + 1, false); // pattern + myScan = tcl_command_ARG(myScan, i + 2, false); // whitespace + if (myScan != NULL) // script + { + myScan->after << "script" << tcl.list_commandwords[i+3]; + } + else + { + myScan = tcl.scan.at(0); + myScan = tcl_scan_start('?', *tcl.list_commandwords.at(i+3), + myScan->ns, myScan->entry_cl, myScan->entry_fn); + } + //printf("pattern=%s\n",(const char*) (*tcl.list_commandwords.at(i+1)).utf8()); + //printf("script=%s\n",(const char*) (*tcl.list_commandwords.at(i+3)).utf8()); + } + } + else + { + // not properly detected syntax + tcl_war("Invalid switch syntax: %d options followed by %d tokens.\n", + lastOptionIndex / 2, (tcl.list_commandwords.count() - 1) / 2 - lastOptionIndex / 2); + for (i = lastOptionIndex + 1; i <= tcl.list_commandwords.count(); i++) + { + myScan = tcl_command_ARG(myScan, i, false); + } + } +} + +//! Handle internal tcl commands. // "catch script ?resultVarName? ?optionsVarName?" static void tcl_command_CATCH() { @@ -2494,8 +2669,14 @@ tcl_inf("->\n"); } /* * Start of internal tcl keywords - * Ready: eval, catch, if, for, foreach, while + * Ready: switch, eval, catch, if, for, foreach, while */ + if (myStr=="switch") + { + if (tcl.list_commandwords.count() < 5) {myLine=__LINE__;goto command_warn;} + tcl_command_SWITCH(); + goto command_end; + } if (myStr=="eval") { if (tcl.list_commandwords.count() < 3) {myLine=__LINE__;goto command_warn;} diff --git a/testing/060/060__command__switch_8tcl.xml b/testing/060/060__command__switch_8tcl.xml new file mode 100644 index 0000000..d9424ef --- /dev/null +++ b/testing/060/060__command__switch_8tcl.xml @@ -0,0 +1,358 @@ + + + + 060_command_switch.tcl + + + + Invoked + args + Invoked + + should be reference by every proc below + + + + + + + a + b + c + d + e + f + g + h + i + j + k + l + m + n + o + p + q + r + s + x + y + + + + NotInvoked + args + NotInvoked + + must not be reference by every proc below + + + + + + + y + + + + a + args + a + + + + + + + + Invoked + + + + b + args + b + + + + + + + + Invoked + + + + c + args + c + + + + + + + + Invoked + + + + d + args + d + + + + + + + + Invoked + + + + e + args + e + + + + + + + + Invoked + + + + f + args + f + + + + + + + + Invoked + + + + g + args + g + + + + + + + + Invoked + + + + h + args + h + + + + + + + + Invoked + + + + i + args + i + + + + + + + + Invoked + + + + j + args + j + + + + + + + + Invoked + + + + k + args + k + + + + + + + + Invoked + + + + l + args + l + + + + + + + + Invoked + + + + m + args + m + + + + + + + + Invoked + + + + n + args + n + + + + + + + + Invoked + + + + o + args + o + + + + + + + + Invoked + + + + p + args + p + + + + + + + + Invoked + + + + q + args + q + + + + + + + + Invoked + + + + r + args + r + + + + + + + + Invoked + + + + s + args + s + + + + + + + + Invoked + + + + x + args + x + + + + + + + + Invoked + + + + y + args + y + + + + + + + + Invoked + NotInvoked + + + + + + + + + diff --git a/testing/060_command_switch.tcl b/testing/060_command_switch.tcl new file mode 100644 index 0000000..ab556d0 --- /dev/null +++ b/testing/060_command_switch.tcl @@ -0,0 +1,238 @@ +#// objective: tests processing of switch, only references/referencedby relations are relevant +#// check: 060__command__switch_8tcl.xml +#// config: REFERENCED_BY_RELATION = yes +#// config: REFERENCES_RELATION = yes +#// config: EXTRACT_ALL = yes +#// config: INLINE_SOURCES = no + +## +# \brief should be reference by every proc below +proc Invoked args { + puts "Procedure \"Invoked\" is invoked indeed. Ok." + return $args +} +## +# \brief must not be reference by every proc below +proc NotInvoked args { + puts "Procedure \"NotInvoked\" is invoked. Not Ok!" + return $args +} +# +# check if call references work at all +proc a args { + Invoked NotInvoked + return +} +# +# switch command +# switch ?options? string pattern body ?pattern body ...? +proc b args { + switch value NotInvoked { + } NotInvoked { + } default { + Invoked + } + return +} +proc c args { + switch value NotInvoked { + } [Invoked] { + } default { + } + return +} +proc d args { + switch NotInvoked pattern { + } [Invoked] { + } default { + } + return +} +proc e args { + switch [Invoked] pattern { + } NotInvoked { + } default { + } + return +} +proc f args { + switch -exact value pattern { + } NotInvoked { + } default { + Invoked + } + return +} +proc g args { + switch -exact -- value pattern { + } NotInvoked { + } default { + Invoked + } + return +} +proc h args { + switch -exact -- -value pattern { + } NotInvoked { + } default { + Invoked + } + return +} +# switch ?options? string {pattern body ?pattern body ...?} +proc i args { + switch value { + NotInvoked { + } + NotInvoked { + } + default { + Invoked + } + } + return +} +proc j args { + switch vale { + NotInvoked { + } + [NotInvoked] { + } + default { + Invoked + } + } + return +} +proc k args { + switch NotInvoked { + [NotInvoked] { + } + NotInvoked { + Invoked + } + default { + } + } + return +} +proc l args { + switch [Invoked] { + pattern { + } + NotInvoked { + } + default { + } + } + return +} +proc m args { + switch -exact value { + pattern { + } + NotInvoked { + } + default { + Invoked + } + } + return +} +proc n args { + switch -exact -- value { + pattern { + } + NotInvoked { + } + default { + Invoked + } + } + return +} +proc o args { + switch -exact -- -value { + pattern { + } + NotInvoked { + } + default { + Invoked + } + } + return +} +proc p args { + switch -exact -- inquotes { + "inquotes" { + Invoked + } + default { + } + } + return +} +proc q args { + switch -exact -- "in quotes" { + "in quotes" { + Invoked + } + default { + } + } + return +} +proc r args { + switch -exact -- inbraces { + {inbraces} { + Invoked + } + default { + } + } + return +} +proc s args { + switch -exact -- {in braces} { + {in braces} { + Invoked + } + default { + } + } + return +} +# wrong syntax +proc x args { + catch {switch -exact -- [Invoked] pattern1 NotInvoked pattern2} + return +} +# The current version does not check the last argument beforehand. +# Therefore, all script elements are evaluated as scripts before +# the parser detects the dangling pattern. It throws a warning, at the very least. +# Anyway, for working code the documentation will be correct. +proc y args { + catch {switch -exact -- [Invoked] { + pattern { + NotInvoked + } + NotInvoked { + NotInvoked + } + default { + NotInvoked + } + pattern + }} + return +} +# +# call all single letter procs +# let tcl check what is called and what is not called +foreach p [info procs ?] { + puts "Check procedure \"$p\"" + $p +} +exit + -- cgit v0.12 From 06bd53ac6acee5fb83d9f2b5ded1c55c8a069b29 Mon Sep 17 00:00:00 2001 From: wtschueller Date: Thu, 19 Jun 2014 21:43:14 +0200 Subject: Tcl: refactor similar code into tcl_codify_token function --HG-- extra : rebase_source : 71a597ee1427c9ee52d8879ffc360f91912f8561 --- src/tclscanner.l | 143 ++++++++++++++++++------------------------------------- 1 file changed, 47 insertions(+), 96 deletions(-) diff --git a/src/tclscanner.l b/src/tclscanner.l index f9878db..24c0a7b 100644 --- a/src/tclscanner.l +++ b/src/tclscanner.l @@ -714,6 +714,40 @@ static void tcl_codify_cmd(const char *s,int i) { tcl_codify(s,(*tcl.list_commandwords.at(i)).utf8()); } +//! codify a string token +// +// codifies string according to type. +// Starts a new scan context if needed (*myScan==0 and type == "script"). +// Returns NULL or the created scan context. +// +static tcl_scan *tcl_codify_token(tcl_scan *myScan, const QCString type, const QCString string) +{ + if (myScan != NULL) + { + if (type != NULL) + { + myScan->after << type << string; + } + else + { + myScan->after << "NULL" << string; + } + } + else + { + if (qstrcmp(type, "script") == 0) + { + myScan = tcl.scan.at(0); + myScan = tcl_scan_start('?', string, + myScan->ns, myScan->entry_cl, myScan->entry_fn); + } + else + { + tcl_codify((const char*)type, string); + } + } + return myScan; +} //----------------------------------------------------------------------------- #undef YY_INPUT @@ -1716,14 +1750,7 @@ static tcl_scan *tcl_command_ARG(tcl_scan *myScan, unsigned int i, bool ignoreOu if (i%2 != 0) { // handle white space - if (myScan!=NULL) - { - myScan->after << "NULL" << myName; - } - else - { - tcl_codify(NULL,myName); - } + myScan = tcl_codify_token(myScan, "NULL", myName); } else { @@ -1766,29 +1793,13 @@ static tcl_scan *tcl_command_ARG(tcl_scan *myScan, unsigned int i, bool ignoreOu { // the first opening bracket, output what we have so far myStr+=c; - if (myScan!=NULL) - { - myScan->after << "NULL" << myStr; - } - else - { - tcl_codify(NULL,myStr); - } + myScan = tcl_codify_token(myScan, "NULL", myStr); myStr=""; } else if (c==']' && !backslashed && insideBrackets==0 && insideBraces==0) { // the last closing bracket, start recursion, switch to deferred - if (myScan!=NULL) - { - myScan->after << "script" << myStr; - } - else - { - myScan=tcl.scan.at(0); - myScan = tcl_scan_start('?',myStr, - myScan->ns,myScan->entry_cl,myScan->entry_fn); - } + myScan = tcl_codify_token(myScan, "script", myStr); myStr=""; myStr+=c; } @@ -1797,20 +1808,13 @@ static tcl_scan *tcl_command_ARG(tcl_scan *myScan, unsigned int i, bool ignoreOu myStr+=c; } } - if (myScan!=NULL) + if (i == 0 && myScan == NULL) { - myScan->after << "NULL" << myStr; + tcl_codify_link(myStr); } else { - if (i==0) - { - tcl_codify_link(myStr); - } - else - { - tcl_codify(NULL,myStr); - } + myScan = tcl_codify_token(myScan, "NULL", myStr); } } return (myScan); @@ -1887,14 +1891,7 @@ D { inBraces = true; token = token.mid(1, token.length() - 2); - if (myScan!=NULL) - { - myScan->after << "NULL" << QCString("{"); - } - else - { - tcl_codify(NULL,QCString("{")); - } + myScan = tcl_codify_token(myScan, "NULL", QCString("{")); } // ToDo: check if multibyte chars are handled correctly while (token.length() > 0) @@ -1906,66 +1903,29 @@ D // handle leading whitespace/opening brace/double quotes if (elem - token > 0) { - if (myScan != NULL) - { - myScan->after << "NULL" << token.left(elem - token); - } - else - { - tcl_codify(NULL, token.left(elem - token)); - } + myScan = tcl_codify_token(myScan, "NULL", token.left(elem - token)); } // handle actual element without braces/double quotes if (nextIsPattern) { - if (myScan != NULL) - { - myScan->after << "NULL" << token.mid(elem - token,size); - } - else - { - tcl_codify(NULL,token.mid(elem - token, size)); - } + myScan = tcl_codify_token(myScan, "NULL", token.mid(elem - token,size)); //printf("pattern=%s\n",(const char*) token.mid(elem - token, size)); } else { - if (myScan != NULL) - { - myScan->after << "script" << token.mid(elem - token, size); - } - else - { - myScan = tcl.scan.at(0); - myScan = tcl_scan_start('?', token.mid(elem - token, size), - myScan->ns, myScan->entry_cl, myScan->entry_fn); - } + myScan = tcl_codify_token(myScan, "script", token.mid(elem - token, size)); //printf("script =%s\n", (const char*) token.mid(elem - token, size)); } // handle trailing whitespace/closing brace/double quotes if (next - elem - size > 0) { - if (myScan != NULL) - { - myScan->after << "NULL" << token.mid(elem - token + size, next - elem - size); - } - else - { - tcl_codify(NULL, token.mid(elem - token + size, next - elem - size)); - } + myScan = tcl_codify_token(myScan, "NULL", token.mid(elem - token + size, next - elem - size)); } nextIsPattern = !nextIsPattern; token = token.mid(next - token); } if (inBraces) { - if (myScan != NULL) - { - myScan->after << "NULL" << QCString("}"); - } - else - { - tcl_codify(NULL, QCString("}")); - } + myScan = tcl_codify_token(myScan, "NULL", QCString("}")); } if (!nextIsPattern) { @@ -1985,16 +1945,7 @@ D myScan = tcl_command_ARG(myScan, i + 0, false); // whitespace myScan = tcl_command_ARG(myScan, i + 1, false); // pattern myScan = tcl_command_ARG(myScan, i + 2, false); // whitespace - if (myScan != NULL) // script - { - myScan->after << "script" << tcl.list_commandwords[i+3]; - } - else - { - myScan = tcl.scan.at(0); - myScan = tcl_scan_start('?', *tcl.list_commandwords.at(i+3), - myScan->ns, myScan->entry_cl, myScan->entry_fn); - } + myScan = tcl_codify_token(myScan, "script", (*tcl.list_commandwords.at(i+3)).utf8()); // script //printf("pattern=%s\n",(const char*) (*tcl.list_commandwords.at(i+1)).utf8()); //printf("script=%s\n",(const char*) (*tcl.list_commandwords.at(i+3)).utf8()); } -- cgit v0.12 From 470143192d0c8cf90ad84a66226d48060cc713db Mon Sep 17 00:00:00 2001 From: wtschueller Date: Sat, 12 Jul 2014 20:34:46 +0200 Subject: Tcl: correct namespace resolution in case of INLINE_SOURCES = YES --- src/tclscanner.l | 20 ++++++++++- testing/062/namespacen1.xml | 42 ++++++++++++++++++++++ testing/062/namespacen2.xml | 42 ++++++++++++++++++++++ testing/062/namespacen3.xml | 42 ++++++++++++++++++++++ testing/062_namespace_resolution.tcl | 68 ++++++++++++++++++++++++++++++++++++ 5 files changed, 213 insertions(+), 1 deletion(-) create mode 100644 testing/062/namespacen1.xml create mode 100644 testing/062/namespacen2.xml create mode 100644 testing/062/namespacen3.xml create mode 100644 testing/062_namespace_resolution.tcl diff --git a/src/tclscanner.l b/src/tclscanner.l index 24c0a7b..e93152b 100644 --- a/src/tclscanner.l +++ b/src/tclscanner.l @@ -534,6 +534,24 @@ static void tcl_name(const QCString &ns0, const QCString &name0, QCString &ns, Q } } +//! Check name. Strip namespace qualifiers from name0 if inside inlined code segment. +// @return 'ns' and 'name' of given current 'ns0' and 'name0' +static void tcl_name_SnippetAware(const QCString &ns0, const QCString &name0, QCString &ns, QCString &name) +{ + // If we are inside an inlined code snippet then ns0 + // already containes the complete namespace path. + // Any namespace qualifiers in name0 are redundant. + int i = name0.findRev("::"); + if (i>=0 && tcl.memberdef) + { + tcl_name(ns0, name0.mid(i+2), ns, name); + } + else + { + tcl_name(ns0, name0, ns, name); + } +} + // Check and return namespace entry. // @return namespace entry Entry* tcl_entry_namespace(const QCString ns) @@ -2099,7 +2117,7 @@ D tcl_codify_cmd(NULL,3); tcl_codify_cmd(NULL,4); tcl_codify_cmd(NULL,5); - tcl_name(myScan->ns,(*tcl.list_commandwords.at(2)).utf8(),myNs,myName); + tcl_name_SnippetAware(myScan->ns,(*tcl.list_commandwords.at(2)).utf8(),myNs,myName); if (myNs.length()) { myEntryNs = tcl_entry_namespace(myNs); diff --git a/testing/062/namespacen1.xml b/testing/062/namespacen1.xml new file mode 100644 index 0000000..0ef31ff --- /dev/null +++ b/testing/062/namespacen1.xml @@ -0,0 +1,42 @@ + + + + n1 + n1::n1 + + + + n1::p1 + args + p1 + + + + + + + + p2 + + + + n1::p2 + args + p2 + + + + + + + + p1 + + + + + + + + + diff --git a/testing/062/namespacen2.xml b/testing/062/namespacen2.xml new file mode 100644 index 0000000..39c21d2 --- /dev/null +++ b/testing/062/namespacen2.xml @@ -0,0 +1,42 @@ + + + + n2 + n2::n2 + + + + n2::p1 + args + p1 + + + + + + + + p2 + + + + n2::p2 + args + p2 + + + + + + + + p1 + + + + + + + + + diff --git a/testing/062/namespacen3.xml b/testing/062/namespacen3.xml new file mode 100644 index 0000000..25c803c --- /dev/null +++ b/testing/062/namespacen3.xml @@ -0,0 +1,42 @@ + + + + n3 + n3::n3 + + + + n3::p1 + args + p1 + + + + + + + + p2 + + + + n3::p2 + args + p2 + + + + + + + + p1 + + + + + + + + + diff --git a/testing/062_namespace_resolution.tcl b/testing/062_namespace_resolution.tcl new file mode 100644 index 0000000..dcc6701 --- /dev/null +++ b/testing/062_namespace_resolution.tcl @@ -0,0 +1,68 @@ +#// objective: tests correct namespace resolution, only references/referencedby relations are relevant +#// check: namespacen1.xml +#// check: namespacen2.xml +#// check: namespacen3.xml +#// config: REFERENCED_BY_RELATION = yes +#// config: REFERENCES_RELATION = yes +#// config: EXTRACT_ALL = yes +#// config: INLINE_SOURCES = yes + +# now: combine namespace eval and qualified names +namespace eval n1 { + proc p1 args { + array set info [info frame 0]; puts -nonewline ->$info(proc) + p2 + return + } + proc p2 args { + array set info [info frame 0]; puts -nonewline ->$info(proc) + return + } + namespace eval n1 { + proc p1 args { + array set info [info frame 0]; puts -nonewline ->$info(proc) + return + } + } +} +# same thing, but fully qualified proc names +namespace eval ::n2 {} +namespace eval ::n2::n2 {} +proc ::n2::p1 args { + array set info [info frame 0]; puts -nonewline ->$info(proc) + p2 + return +} +proc ::n2::p2 args { + array set info [info frame 0]; puts -nonewline ->$info(proc) + return +} +proc ::n2::n2::p2 args { + array set info [info frame 0]; puts -nonewline ->$info(proc) + return +} +# same thing, without leading :: +namespace eval n3 {} +namespace eval n3::n3 {} +proc n3::p1 args { + array set info [info frame 0]; puts -nonewline ->$info(proc) + p2 + return +} +proc n3::p2 args { + array set info [info frame 0]; puts -nonewline ->$info(proc) + return +} +proc n3::n3::p2 args { + array set info [info frame 0]; puts -nonewline ->$info(proc) + return +} +# now, check with tcl what is called +n1::p1 +puts "" +n2::p1 +puts "" +n3::p1 +puts "" +exit + -- cgit v0.12 From c6aaf0a4c35db27f968a7a6d0b9fa25b5b311bc3 Mon Sep 17 00:00:00 2001 From: wtschueller Date: Sat, 12 Jul 2014 20:35:31 +0200 Subject: Tcl: test 057 additionally tests mutual Xrefs for two files --- testing/057/057__caller__graphs_8tcl.xml | 38 ++++++++++++++++++++++---- testing/057/__057__caller__graphs_8tcl.xml | 28 +++++++++++++++++++ testing/057/namespace1.xml | 30 ++++++++++---------- testing/057/namespace1_1_11.xml | 4 +-- testing/057/namespace1_1_11_1_11.xml | 4 +-- testing/057/namespace2.xml | 8 +++--- testing/057/namespace2_1_12.xml | 6 ++-- testing/057/namespace2_1_12_1_12.xml | 6 ++-- testing/057/namespace2_1_12_1_12_1_12.xml | 6 ++-- testing/057/namespace2_1_12_1_12_1_12_1_12.xml | 8 +++--- testing/057/namespacebar.xml | 18 ++++++------ testing/057/namespacefoo.xml | 6 ++-- testing/057_caller_graphs.tcl | 17 ++++++++++++ 13 files changed, 126 insertions(+), 53 deletions(-) create mode 100644 testing/057/__057__caller__graphs_8tcl.xml diff --git a/testing/057/057__caller__graphs_8tcl.xml b/testing/057/057__caller__graphs_8tcl.xml index d2e3d84..4c54e1c 100644 --- a/testing/057/057__caller__graphs_8tcl.xml +++ b/testing/057/057__caller__graphs_8tcl.xml @@ -24,7 +24,7 @@ - + @@ -37,8 +37,8 @@ - - 1::test3 + + 1::test3 @@ -51,8 +51,36 @@ - - 2::next + + 2::next + + + + master + args + master + + + + + + + + inFileB + + + + inFileA + args + inFileA + + + + + + + + inFileB diff --git a/testing/057/__057__caller__graphs_8tcl.xml b/testing/057/__057__caller__graphs_8tcl.xml new file mode 100644 index 0000000..2fdcf6a --- /dev/null +++ b/testing/057/__057__caller__graphs_8tcl.xml @@ -0,0 +1,28 @@ + + + + _057_caller_graphs.tcl + + + + inFileB + args + inFileB + + + + + + + + inFileA + master + + + + + + + + + diff --git a/testing/057/namespace1.xml b/testing/057/namespace1.xml index e40300d..e74d8fe 100644 --- a/testing/057/namespace1.xml +++ b/testing/057/namespace1.xml @@ -15,9 +15,9 @@ - - test1 - test5 + + test1 + test5 @@ -30,8 +30,8 @@ - - test2 + + test2 @@ -44,8 +44,8 @@ - - baz + + baz @@ -58,8 +58,8 @@ - - bar + + bar @@ -72,8 +72,8 @@ - - bar + + bar @@ -86,8 +86,8 @@ - - 1::1::bar + + 1::1::bar @@ -100,8 +100,8 @@ - - baz + + baz diff --git a/testing/057/namespace1_1_11.xml b/testing/057/namespace1_1_11.xml index 157ab5e..e5c5596 100644 --- a/testing/057/namespace1_1_11.xml +++ b/testing/057/namespace1_1_11.xml @@ -15,8 +15,8 @@ - - 1::test4 + + 1::test4 diff --git a/testing/057/namespace1_1_11_1_11.xml b/testing/057/namespace1_1_11_1_11.xml index 2f5a685..caccbe4 100644 --- a/testing/057/namespace1_1_11_1_11.xml +++ b/testing/057/namespace1_1_11_1_11.xml @@ -14,13 +14,13 @@ - + - + diff --git a/testing/057/namespace2.xml b/testing/057/namespace2.xml index 47a9fcf..6ea122c 100644 --- a/testing/057/namespace2.xml +++ b/testing/057/namespace2.xml @@ -15,10 +15,10 @@ - - 2::2::next - next - 2::2::2::2::2::next + + 2::2::next + next + 2::2::2::2::2::next diff --git a/testing/057/namespace2_1_12.xml b/testing/057/namespace2_1_12.xml index 3338473..d2a589a 100644 --- a/testing/057/namespace2_1_12.xml +++ b/testing/057/namespace2_1_12.xml @@ -15,9 +15,9 @@ - - 2::2::2::next - 2::next + + 2::2::2::next + 2::next diff --git a/testing/057/namespace2_1_12_1_12.xml b/testing/057/namespace2_1_12_1_12.xml index 259ef25..d04a73c 100644 --- a/testing/057/namespace2_1_12_1_12.xml +++ b/testing/057/namespace2_1_12_1_12.xml @@ -15,9 +15,9 @@ - - 2::2::2::2::next - 2::2::next + + 2::2::2::2::next + 2::2::next diff --git a/testing/057/namespace2_1_12_1_12_1_12.xml b/testing/057/namespace2_1_12_1_12_1_12.xml index cea3062..980906d 100644 --- a/testing/057/namespace2_1_12_1_12_1_12.xml +++ b/testing/057/namespace2_1_12_1_12_1_12.xml @@ -15,9 +15,9 @@ - - 2::2::2::2::2::next - 2::2::2::next + + 2::2::2::2::2::next + 2::2::2::next diff --git a/testing/057/namespace2_1_12_1_12_1_12_1_12.xml b/testing/057/namespace2_1_12_1_12_1_12_1_12.xml index 65bfa00..0c6957b 100644 --- a/testing/057/namespace2_1_12_1_12_1_12_1_12.xml +++ b/testing/057/namespace2_1_12_1_12_1_12_1_12.xml @@ -14,15 +14,15 @@ - - 2::next - 2::2::2::2::next + + 2::next + 2::2::2::2::next - + diff --git a/testing/057/namespacebar.xml b/testing/057/namespacebar.xml index 642986b..3c0f6e9 100644 --- a/testing/057/namespacebar.xml +++ b/testing/057/namespacebar.xml @@ -14,9 +14,9 @@ - - baz - foo::master + + baz + foo::master @@ -29,9 +29,9 @@ - - bazbaz - slave + + bazbaz + slave @@ -44,14 +44,14 @@ - - baz + + baz - + diff --git a/testing/057/namespacefoo.xml b/testing/057/namespacefoo.xml index 11f8053..2aae8ea 100644 --- a/testing/057/namespacefoo.xml +++ b/testing/057/namespacefoo.xml @@ -14,14 +14,14 @@ - - bar::slave + + bar::slave - + diff --git a/testing/057_caller_graphs.tcl b/testing/057_caller_graphs.tcl index 25bf1e7..f6e0e77 100644 --- a/testing/057_caller_graphs.tcl +++ b/testing/057_caller_graphs.tcl @@ -1,5 +1,6 @@ #// objective: test for completeness and correctness of references/referencedby relations #// check: 057__caller__graphs_8tcl.xml +#// check: __057__caller__graphs_8tcl.xml #// check: namespacebar.xml #// check: namespacefoo.xml #// check: namespace1.xml @@ -14,6 +15,7 @@ #// config: INLINE_SOURCES = no #// config: REFERENCED_BY_RELATION = yes #// config: REFERENCES_RELATION = yes +#// config: INPUT = 057_caller_graphs.tcl _057_caller_graphs.tcl # config: HAVE_DOT = yes # config: CALLER_GRAPH = yes # config: CALL_GRAPH = yes @@ -126,6 +128,20 @@ proc ::2::2::2::2::2::next args { array set info [info frame 0]; puts $info(proc) 2::next } +# +# cross check with two files +# If doxygen did not do two passes, then xrefs would depend on file order +# and would be incomplete. +source _057_caller_graphs.tcl +proc master args { + array set info [info frame 0]; puts -nonewline ->$info(proc) + inFileB + return +} +proc inFileA args { + array set info [info frame 0]; puts -nonewline ->$info(proc) + return +} # now, check with tcl what is called foo::master puts "" @@ -134,5 +150,6 @@ foreach proc [lsort [info procs ::1::test?]] { puts "" } ::next +master exit -- cgit v0.12 From 73e7c340f555291d4264b2f83caacf59a5a3395f Mon Sep 17 00:00:00 2001 From: wtschueller Date: Sat, 12 Jul 2014 21:37:10 +0200 Subject: Tcl: add missing file that breaks test 057 --- testing/_057_caller_graphs.tcl | 4 ++++ 1 file changed, 4 insertions(+) create mode 100644 testing/_057_caller_graphs.tcl diff --git a/testing/_057_caller_graphs.tcl b/testing/_057_caller_graphs.tcl new file mode 100644 index 0000000..24b9c20 --- /dev/null +++ b/testing/_057_caller_graphs.tcl @@ -0,0 +1,4 @@ +proc inFileB args { + array set info [info frame 0]; puts -nonewline ->$info(proc) + inFileA +} -- cgit v0.12