Index: /branches/rel_apv_10_7_2_5_irule/usr/click/bin/atcp_config/atcp_config.c =================================================================== --- /branches/rel_apv_10_7_2_5_irule/usr/click/bin/atcp_config/atcp_config.c (revision 38731) +++ /branches/rel_apv_10_7_2_5_irule/usr/click/bin/atcp_config/atcp_config.c (working copy) @@ -1650,6 +1650,40 @@ {"atcp31", "29", ""}, {"atcp32", "30", ""}, {"atcp33", "31", ""}, + + {"atcp34", "32", ""}, + {"atcp35", "33", ""}, + {"atcp36", "34", ""}, + {"atcp37", "35", ""}, + {"atcp38", "36", ""}, + {"atcp39", "37", ""}, + {"atcp40", "38", ""}, + {"atcp41", "39", ""}, + {"atcp42", "40", ""}, + {"atcp43", "41", ""}, + {"atcp44", "42", ""}, + {"atcp45", "43", ""}, + {"atcp46", "44", ""}, + {"atcp47", "45", ""}, + {"atcp48", "46", ""}, + {"atcp49", "47", ""}, + {"atcp50", "48", ""}, + {"atcp51", "49", ""}, + {"atcp52", "50", ""}, + {"atcp53", "51", ""}, + {"atcp54", "52", ""}, + {"atcp55", "53", ""}, + {"atcp56", "54", ""}, + {"atcp57", "55", ""}, + {"atcp58", "56", ""}, + {"atcp59", "57", ""}, + {"atcp60", "58", ""}, + {"atcp61", "59", ""}, + {"atcp62", "60", ""}, + {"atcp63", "61", ""}, + {"atcp64", "62", ""}, + {"atcp65", "63", ""}, + {"atcp_l4thread_taskqueue_integration", "true", " #Change to false if run L4 & taskqueue independently"}, {"atcp_taskqueue_number", "32", " #taskqueue config ignored if atcp_l4thread_taskqueue_integration=true"}, }; @@ -2619,6 +2653,7 @@ offset = 0; for (i = 0; i < ncpus; i++) { cpuids[offset] = i; + cpuids[offset + ncpus] = i; offset += cpu_logical; if (offset >= ncpus) { /* list another row */ @@ -2626,6 +2661,6 @@ offset += 1; } } - cpuids[ncpus] = -1; + cpuids[ncpus*2] = -1; } #endif Index: /branches/rel_apv_10_7_2_5_irule/usr/click/lib/libepolicy/APIForIDE.c =================================================================== --- /branches/rel_apv_10_7_2_5_irule/usr/click/lib/libepolicy/APIForIDE.c (revision 38731) +++ /branches/rel_apv_10_7_2_5_irule/usr/click/lib/libepolicy/APIForIDE.c (working copy) @@ -149,6 +149,10 @@ Tcl_DictObjPut(NULL, dict, Tcl_NewStringObj("tcp::is_server_conn", -1), Tcl_NewStringObj("check whether current connection is server connection", -1)); Tcl_DictObjPut(NULL, dict, Tcl_NewStringObj("tcp::splice", -1), Tcl_NewStringObj("splice the client and server connection", -1)); Tcl_DictObjPut(NULL, dict, Tcl_NewStringObj("tcp::bypass_server_data", -1), Tcl_NewStringObj("not parse server data", -1)); + Tcl_DictObjPut(NULL, dict, Tcl_NewStringObj("tcp::connect", -1), Tcl_NewStringObj("opens a sideband connection to the specified destination", -1)); + Tcl_DictObjPut(NULL, dict, Tcl_NewStringObj("tcp::send", -1), Tcl_NewStringObj("send data on a specified sideband connection", -1)); + Tcl_DictObjPut(NULL, dict, Tcl_NewStringObj("tcp::recv", -1), Tcl_NewStringObj("receive data from an existing sideband connection", -1)); + Tcl_DictObjPut(NULL, dict, Tcl_NewStringObj("tcp::close", -1), Tcl_NewStringObj("closes an existing sideband connection", -1)); Tcl_DictObjPut(NULL, dict, Tcl_NewStringObj("application::finish_handshake", -1), Tcl_NewStringObj("close client connection", -1)); Index: /branches/rel_apv_10_7_2_5_irule/usr/click/lib/libepolicy/slb_utils.h =================================================================== --- /branches/rel_apv_10_7_2_5_irule/usr/click/lib/libepolicy/slb_utils.h (revision 38731) +++ /branches/rel_apv_10_7_2_5_irule/usr/click/lib/libepolicy/slb_utils.h (working copy) @@ -31,7 +31,6 @@ #define CUSTOM_TCP_OPTION_MAX_LENGTH 40 - typedef enum { SLB_SUCCRSS = 0, ERR_UNKNOWN, @@ -40,6 +39,12 @@ REACH_LIMIT, } TCP_OPTION_ERR_CODE; +typedef enum { + IPV4, + IPV6, + VS +} SERVER_TYPE; + struct _slb_conn_info; int slb_group_name_to_membership(char *name, uint32_t source_ip, struct in6_addr *source_ip6, uint16_t source_port, char *rs_name, void **membership, void *conn); int slb_rs_name_to_membership(char *rs_name, char*g_name, void **membership); @@ -91,7 +96,9 @@ int check_vs_proto_type(void *vs); void increase_vs_request_rate(void *vs); int is_need_drop_resp(void *conn); - +slb_vs_t *slb_find_vs_by_name(char *vs_name); +slb_rs_t *slb_l4_find_rs_by_vs(char *vs_name, struct ip_addr *client_addr, int client_port); +SERVER_TYPE ip_port_parser(const char *input, char *ip, int *port); #ifdef __cplusplus } Index: /branches/rel_apv_10_7_2_5_irule/usr/click/lib/libepolicy/slb_utils.c =================================================================== --- /branches/rel_apv_10_7_2_5_irule/usr/click/lib/libepolicy/slb_utils.c (revision 38731) +++ /branches/rel_apv_10_7_2_5_irule/usr/click/lib/libepolicy/slb_utils.c (working copy) @@ -13,7 +13,6 @@ #include #include - #include #include #include @@ -34,6 +33,7 @@ #include #include +#include #include #include @@ -1575,3 +1575,77 @@ return 0; } +slb_vs_t *slb_find_vs_by_name(char *vs_name) +{ + slb_vs_t *temp_vs; + int i; + struct clickaddresses *click_addr; + slb_vs_t *slb_vs_table = NULL; + uint32_t slb_vs_limit = 0; + size_t len = 0; + + len = sizeof(click_addr); + if (u_sysctlbyname("kern.clickbuf", &click_addr, &len, NULL, 0) < 0) { + return NULL; + } + + slb_vs_table = (slb_vs_t *)click_addr ->slb_vs_table; + slb_vs_limit = click_addr ->g_slb_vs_limit; + for (i = 0; i < slb_vs_limit; i++) { + if(slb_vs_table[i].name != NULL && strcmp(vs_name, slb_vs_table[i].name) == 0) { + temp_vs = &slb_vs_table[i]; + return temp_vs; + } + } + + return NULL; +} + +slb_rs_t *slb_l4_find_rs_by_vs(char *vs_name, struct ip_addr *client_addr, int client_port) +{ + slb_vs_t *vs = slb_find_vs_by_name(vs_name); + if(vs == NULL) { + return NULL; + } + + slb_rs_t *rs = NULL; + slb_l4_args_t slb_args; + + bzero(&slb_args, sizeof(slb_l4_args_t)); + slb_args.source_port = client_port; + + if (client_addr->is_ipv6) { + slb_args.source_ip6 = &client_addr->ipv6; + } else { + slb_args.source_ip.s_addr = client_addr->ipv4; + } + + if(SLB_IS_VS_IPV6(vs)) { + rs = slb_rs_lookup6(vs, &slb_args, NULL); + } else { + rs = slb_rs_lookup(vs, &slb_args, NULL); + } + + return rs; +} + +SERVER_TYPE ip_port_parser(const char *input, char *ip, int *port) +{ + /* IPv6 format [IPv6]:port */ + if (strchr(input, '[') && strchr(input, ']')) { + struct sockaddr_in6 sa6; + sscanf(input, "[%[^]]]:%d", ip, port); + if (inet_pton(AF_INET6, ip, &(sa6.sin6_addr)) == 1) { + return IPV6; + } + /* IPv4 format IPv4:port */ + } else if (strchr(input, ':')) { + struct sockaddr_in sa; + sscanf(input, "%[^:]:%d", ip, port); + if (inet_pton(AF_INET, ip, &(sa.sin_addr)) == 1) { + return IPV4; + } + } + + return VS; +} Index: /branches/rel_apv_10_7_2_5_irule/usr/click/lib/libepolicy/tcp_policy.h =================================================================== --- /branches/rel_apv_10_7_2_5_irule/usr/click/lib/libepolicy/tcp_policy.h (revision 38731) +++ /branches/rel_apv_10_7_2_5_irule/usr/click/lib/libepolicy/tcp_policy.h (working copy) @@ -19,6 +19,100 @@ ePolicy_message *msg, void *client_data); +/* Socket connection limit */ + +#define SOCKET_LONG_QUEUE_TIMEOUT_MS 1000 +#define SOCKET_LONG_QUEUE_LIMIT 240 + +#define SOCKET_MID_QUEUE_TIMEOUT_MS 500 +#define SOCKET_MID_QUEUE_LIMIT 150 + +#define SOCKET_SHORT_QUEUE_TIMEOUT_MS 250 +#define SOCKET_SHORT_QUEUE_LIMIT 80 + +typedef struct socket_node { + long timestamp; + struct socket_node* next; +} socket_node_t; + +typedef struct socket_queue { + socket_node_t *head; + socket_node_t *tail; + int size; + + /* + * Avoid using pthread_mutex_t here as it may cause unexpected errors. + * The reason is unclear. + */ + volatile int locked; +} socket_queue_t; + +static long current_time_ms() { + struct timeval tv; + gettimeofday(&tv, NULL); + return tv.tv_sec * 1000 + tv.tv_usec / 1000; +} + +static void socket_queue_lock(socket_queue_t* q) { + while (__sync_lock_test_and_set(&(q->locked), 1)) { + usleep(1); + } +} + +static void socket_queue_release_lock(socket_queue_t* q) { + __sync_lock_release(&(q->locked)); +} + +static void init_socket_queue_instance(socket_queue_t* q) { + q->head = q->tail = NULL; + q->size = 0; +} + +static void socket_queue_enqueue(socket_queue_t* q) { + if (q == NULL) { + return; + } + + socket_node_t* new_node = (socket_node_t*)malloc(sizeof(socket_node_t)); + new_node->timestamp = current_time_ms(); + new_node->next = NULL; + + socket_queue_lock(q); + if (q->tail) { + q->tail->next = new_node; + } else { + q->head = new_node; + } + q->tail = new_node; + q->size++; + socket_queue_release_lock(q); +} + +static void cleanup_socket_queue_expired(socket_queue_t* q, long timeout) { + if (q == NULL) { + return; + } + + socket_queue_lock(q); + long now = current_time_ms(); + while (q->head && (now - q->head->timestamp > timeout)) { + socket_node_t* temp = q->head; + q->head = q->head->next; + if (q->head == NULL) q->tail = NULL; + free(temp); + q->size--; + } + socket_queue_release_lock(q); +} + +static int get_socket_queue_size(socket_queue_t* q) { + if (q == NULL) { + return -1; + } + + int size = q->size; + return size; +} #ifdef __cplusplus Index: /branches/rel_apv_10_7_2_5_irule/usr/click/lib/libepolicy/tcp_policy.c =================================================================== --- /branches/rel_apv_10_7_2_5_irule/usr/click/lib/libepolicy/tcp_policy.c (revision 38731) +++ /branches/rel_apv_10_7_2_5_irule/usr/click/lib/libepolicy/tcp_policy.c (working copy) @@ -12,12 +12,14 @@ #include #include +#include #include "config.h" #include "tcl.h" #include "epolicy_engine.h" #include "tcp_policy.h" #include "message_frame_utils.h" #include "slb_utils.h" +#include "slb_command.h" #include #include @@ -36,6 +38,77 @@ __thread ePolicy_event_type_id TCP_DATA_event_id = 0; #define FILE_PATH "/ca/ePolicy/lb/scripts/" +#define MIN_TIMEOUT 100 +#define MAX_TIMEOUT 3000 +#define DEFAULT_SEND_TIMEOUT 300 +#define DEFAULT_RECV_TIMEOUT 500 +#define MIN_PORT 49152 +#define MAX_PORT 65535 + +extern uint32_t atcp_L4_nthreads; +extern uint32_t atcp_L4_id_min; + +/* Socket connection limit */ +socket_queue_t socket_long_limit_queue; +socket_queue_t socket_mid_limit_queue; +socket_queue_t socket_short_limit_queue; + +/* + * Check if any socket functions are used. + * It is called in /root/bug1026/usr/src/sys/click/app/slb/slb_vs_policy_kern.c + * + * Using system, popen, regular expressions, and Python proxy execution + * has all caused atcp to crash or encounter errors. + * It is required to use u_system. + */ +void ePolicy_check_socket_script(ePolicy_vs_setting *ePolicy_p) { + + if (ePolicy_p == NULL) { + return; + } + + const char result_file[] = "/tmp/nagelfar132_cmd_proxy_result.txt"; + + char script_path[1024]; + FILE *fp; + char result[1024]; + char *find_targets[] = { + "\"tcp::connect\"", + "\"tcp::send\"", + "\"tcp::recv\"", + "\"tcp::close\"" + }; + + int num_find_targets = sizeof(find_targets) / sizeof(find_targets[0]); + int socket_find = 0; + + char cmd[2048]; + + for(int j = 0; j < MAX_EPOLICY_SCRIPTS && socket_find == 0; j++) { + if(ePolicy_p->runtime_script[j][0] != '\0'){ + remove(result_file); + snprintf(script_path, 1024, "/ca/ePolicy/lb/scripts/%s", ePolicy_p->runtime_script[j]); + snprintf(cmd, 2048, "python /ca/bin/nagelfar132/cmd_proxy.py %s > %s", script_path, result_file); + u_system(cmd); + + if (access(result_file, F_OK) == 0) { + fp = fopen(result_file, "r"); + if (fp) { + while (fgets(result, sizeof(result), fp) && socket_find == 0) { + for (int i = 0; i < num_find_targets && socket_find == 0; i++) { + if (strstr(result, find_targets[i])) { + socket_find = 1; + } + } + } + } + } + } + } + + ePolicy_p->have_socket_script = socket_find; +} + #ifdef MESSAGE_IN_FRAME_CHAIN int copy_msg_body_to_tcl_result( Tcl_Interp *interp, ePolicy_message *msg) { @@ -594,6 +667,369 @@ return TCL_OK; } +int tcp_open_conn(ClientData clientdata, Tcl_Interp *interp, int argc, Tcl_Obj *const argv[]) +{ + CHECK_FOR_COMPILE; + slb_vs_t *vs_p = (slb_vs_t *) Tcl_GetAssocData(interp, ASSOC_DATA_VS_ID, NULL); + + if(argc != 2 && argc != 3) { + ePolicy_log_vs(EPOLICY_LOG_ERROR, vs_p, "%s: invalid param number: %d", __FUNCTION__, argc); + return TCL_ERROR; + } + + const char *server = Tcl_GetString(argv[1]); + char ip_str[INET6_ADDRSTRLEN] = "\0"; + int port = 0; + SERVER_TYPE type = ip_port_parser(server, ip_str, &port); + + /* If input is virtual service, find the corresponding real service */ + if(type == VS) { + /* Get client ip addr and port */ + struct ip_addr *caddr = (struct ip_addr *)Tcl_GetAssocData(interp, ASSOC_DATA_CLIENT_IP_ADDR, NULL); + uint16_t cport = (unsigned int)(uintptr_t)Tcl_GetAssocData(interp, ASSOC_DATA_CLIENT_PORT, NULL); + + slb_rs_t *rs = slb_l4_find_rs_by_vs(server, caddr, cport); + if(rs == NULL) { + ePolicy_log_vs(EPOLICY_LOG_ERROR, vs_p, "tcp::connect: no real service found"); + return TCL_ERROR; + } + + if(strlen(rs->host)) { + snprintf(ip_str, sizeof(ip_str), "%s", rs->host); + } else { + snprintf(ip_str, sizeof(ip_str), "%s", rs->ipstr); + } + + port = rs->port; + } + + /* Get timeout */ + int timeout_ms; + if(Tcl_GetIntFromObj(interp, argv[2], &timeout_ms) != TCL_OK) { + ePolicy_log_vs(EPOLICY_LOG_ERROR, vs_p, "tcp::connect: timeout parameter is not a integer"); + return TCL_ERROR; + } + + if((timeout_ms < MIN_TIMEOUT) || (timeout_ms > MAX_TIMEOUT)) { + ePolicy_log_vs(EPOLICY_LOG_ERROR, vs_p, "tcp::connect: timeout parameter is between 100 and 3000 ms"); + return TCL_ERROR; + } + + /* Clear expired socket records before each script execution. */ + cleanup_socket_queue_expired(&socket_long_limit_queue, SOCKET_LONG_QUEUE_TIMEOUT_MS); + cleanup_socket_queue_expired(&socket_mid_limit_queue, SOCKET_MID_QUEUE_TIMEOUT_MS); + cleanup_socket_queue_expired(&socket_short_limit_queue, SOCKET_SHORT_QUEUE_TIMEOUT_MS); + + /* Socket connection limit */ + int socket_limit_retry = 0; + while ( + get_socket_queue_size(&socket_long_limit_queue) >= SOCKET_LONG_QUEUE_LIMIT && + get_socket_queue_size(&socket_mid_limit_queue) >= SOCKET_MID_QUEUE_LIMIT && + get_socket_queue_size(&socket_short_limit_queue) >= SOCKET_SHORT_QUEUE_LIMIT && + socket_limit_retry < 3 + ) { + Tcl_Sleep(15); + + /* Clear expired socket records before each script execution. */ + cleanup_socket_queue_expired(&socket_long_limit_queue, SOCKET_LONG_QUEUE_TIMEOUT_MS); + cleanup_socket_queue_expired(&socket_mid_limit_queue, SOCKET_MID_QUEUE_TIMEOUT_MS); + cleanup_socket_queue_expired(&socket_short_limit_queue, SOCKET_SHORT_QUEUE_TIMEOUT_MS); + + socket_limit_retry++; + } + + if (socket_limit_retry >= 3) { + ePolicy_log_vs(EPOLICY_LOG_ERROR, vs_p, "tcp::connect: \"%s\" hit the maximum number of socket connections", vs_p->name); + printf("ePolicy - tcp::connect: \"%s\" hit the maximum number of socket connections\n", vs_p->name); + + /* Return channel name is "" */ + const char *channelName = ""; + Tcl_SetObjResult(interp, Tcl_NewStringObj(channelName, strlen(channelName)+1)); + + return TCL_OK; + } + + int retry = 0; + int retry_times = 3; + Tcl_Channel channel; + ClientData sockfd; + + unsigned int seed = time(NULL) + cpuid; + uint32_t atcp_L4_nthreads_half = atcp_L4_nthreads >> 1; + uint32_t atcp_L4_nthreads_quarter = atcp_L4_nthreads >> 2; + int cur_low_hight_area = (cpuid -atcp_L4_nthreads_half - atcp_L4_id_min) < atcp_L4_nthreads_quarter; + char vs_ip_str[INET6_ADDRSTRLEN] = "\0"; + snprintf(vs_ip_str, sizeof(vs_ip_str), "%s", vs_p->ipstr); + + while(1) { + /* Create tcp connection */ + + int dst_port; + int opne_channel_count = 0; + + channel = NULL; + while (channel == NULL) { + int get_port = 0; + + dst_port = rand_r(&seed) % (MAX_PORT - MIN_PORT + 1) + MIN_PORT; + if ( + cur_low_hight_area && + (port + dst_port) % atcp_L4_nthreads_half >= atcp_L4_nthreads_quarter + ) { + get_port = 1; + } else if ( + !cur_low_hight_area && + (port + dst_port) % atcp_L4_nthreads_half < atcp_L4_nthreads_quarter + ) { + get_port = 1; + } + + if (get_port) { + channel = Tcl_OpenTcpClient(interp, port, ip_str, vs_ip_str, dst_port, 1); + if(channel == NULL) { + int errCode = Tcl_GetErrno(); + if (!(errCode == 99 || errCode == 9 || errCode == 22 || errCode == 88 || errCode == 114)) { + const char *errMsg = Tcl_ErrnoMsg(errCode); + ePolicy_log_vs(EPOLICY_LOG_ERROR, vs_p, "tcp::connect: errorCode=%d, %s", errCode, errMsg); + return TCL_ERROR; + } else if (opne_channel_count >= 100) { + ePolicy_log_vs(EPOLICY_LOG_ERROR, vs_p, "tcp::connect: Retrying to open Tcl client failed more than 100 times."); + return TCL_ERROR; + } + opne_channel_count++; + } else { + socket_queue_enqueue(&socket_long_limit_queue); + socket_queue_enqueue(&socket_mid_limit_queue); + socket_queue_enqueue(&socket_short_limit_queue); + } + } + } + + Tcl_GetChannelHandle(channel, TCL_WRITABLE, &sockfd); + + /* Check if connect timeout */ + fd_set writefds; + FD_ZERO(&writefds); + FD_SET((int)(intptr_t)sockfd, &writefds); + + struct timeval tv; + tv.tv_sec = 0; + tv.tv_usec = (timeout_ms * 1000) / (retry + 1); + + /* Check if connect timeout */ + int ret = select((int)(intptr_t)sockfd + 1, NULL, &writefds, NULL, &tv); + if (!(ret > 0 && FD_ISSET((int)(intptr_t)sockfd, &writefds))) { + close(sockfd); + /* Workaround: */ + /* Although server is active, sometimes socket may failed */ + /* due to unkonwn reason, add retry mechanism here */ + if(Tcl_GetErrno() != EBADF || retry >= retry_times) { + ePolicy_log_vs(EPOLICY_LOG_ERROR, vs_p, "tcp::connect: timeout"); + return TCL_ERROR; + } else { + retry++; + Tcl_Sleep(50); + continue; + } + } + + break; + } + + /* Set channel to non-blocking mode */ + if (Tcl_SetChannelOption(interp, channel, "-blocking", "0") != TCL_OK) { + close((int)(intptr_t)sockfd); + return TCL_ERROR; + } + + /* Register socket channel */ + Tcl_RegisterChannel(interp, channel); + + /* Return channel name */ + const char *channelName = Tcl_GetChannelName(channel); + Tcl_SetObjResult(interp, Tcl_NewStringObj(channelName, strlen(channelName)+1)); + + return TCL_OK; +} + +int tcp_send_data(ClientData clientdata, Tcl_Interp *interp, int argc, Tcl_Obj *const argv[]) +{ + CHECK_FOR_COMPILE; + slb_vs_t *vs_p = (slb_vs_t *) Tcl_GetAssocData(interp, ASSOC_DATA_VS_ID, NULL); + + if(argc != 3 && argc != 4) { + ePolicy_log_vs(EPOLICY_LOG_ERROR, vs_p, "%s: invalid param number: %d", __FUNCTION__, argc); + return TCL_ERROR; + } + + /* Get tcl channel by name */ + const char *channelName = Tcl_GetString(argv[1]); + + /* Because it hit the connection limit, channelName is "". */ + if (strcmp(channelName, "") == 0) { + /* Return send bytes */ + ssize_t bytes_written = 0; + Tcl_SetObjResult(interp, Tcl_NewIntObj(bytes_written)); + return TCL_OK; + } + + Tcl_Channel channel = Tcl_GetChannel(interp, channelName, NULL); + if (channel == NULL) { + ePolicy_log_vs(EPOLICY_LOG_ERROR, vs_p, "tcp::send: Invalid channel name"); + return TCL_ERROR; + } + + /* Get send data */ + const char *data = Tcl_GetString(argv[2]); + if(strlen(data) == 0) { + ePolicy_log_vs(EPOLICY_LOG_ERROR, vs_p, "tcp::send: no data to send"); + return TCL_ERROR; + } + + /* Get timeout */ + int timeout_ms = DEFAULT_SEND_TIMEOUT; + if(argc == 4 && Tcl_GetIntFromObj(interp, argv[3], &timeout_ms) != TCL_OK) { + ePolicy_log_vs(EPOLICY_LOG_ERROR, vs_p, "tcp::send: timeout parameter is not a integer"); + return TCL_ERROR; + } + + if((timeout_ms < MIN_TIMEOUT) || (timeout_ms > MAX_TIMEOUT)) { + ePolicy_log_vs(EPOLICY_LOG_ERROR, vs_p, "tcp::send: timeout parameter is between 100 and 3000 ms"); + return TCL_ERROR; + } + + /* Get socket fd by TCL channle */ + ClientData sockfd; + Tcl_GetChannelHandle(channel, TCL_WRITABLE, &sockfd); + + struct timeval tv; + tv.tv_sec = 0; + tv.tv_usec = timeout_ms * 1000; + + fd_set writefds; + FD_ZERO(&writefds); + FD_SET((int)(intptr_t)sockfd, &writefds); + + /* Check if send timeout */ + if (select(sockfd + 1, NULL, &writefds, NULL, &tv) <= 0) { + ePolicy_log_vs(EPOLICY_LOG_ERROR, vs_p, "tcp::send: send timeout"); + Tcl_SetObjResult(interp, Tcl_NewIntObj(0)); + return TCL_OK; + } + + /* Send data */ + ssize_t bytes_written = write(sockfd, data, strlen(data)); + + /* Return send bytes */ + Tcl_SetObjResult(interp, Tcl_NewIntObj(bytes_written)); + + return TCL_OK; +} + +int tcp_recv_data(ClientData clientdata, Tcl_Interp *interp, int argc, Tcl_Obj *const argv[]) +{ + CHECK_FOR_COMPILE; + slb_vs_t *vs_p = (slb_vs_t *) Tcl_GetAssocData(interp, ASSOC_DATA_VS_ID, NULL); + + if(argc != 2 && argc != 3) { + ePolicy_log_vs(EPOLICY_LOG_ERROR, vs_p, "%s: invalid param number: %d", __FUNCTION__, argc); + return TCL_ERROR; + } + + /* Get timeout */ + int timeout_ms = DEFAULT_RECV_TIMEOUT; + if(argc == 3 && Tcl_GetIntFromObj(interp, argv[2], &timeout_ms) != TCL_OK) { + ePolicy_log_vs(EPOLICY_LOG_ERROR, vs_p, "tcp::recv: timeout parameter is not a integer"); + return TCL_ERROR; + } + + if((timeout_ms < MIN_TIMEOUT) || (timeout_ms > MAX_TIMEOUT)) { + ePolicy_log_vs(EPOLICY_LOG_ERROR, vs_p, "tcp::recv: timeout parameter is between 100 and 3000 ms"); + return TCL_ERROR; + } + + const char *channelName = Tcl_GetString(argv[1]); + + /* Because it hit the connection limit, channelName is "". */ + if (strcmp(channelName, "") == 0) { + /* Return recv data */ + Tcl_SetObjResult(interp, Tcl_NewStringObj("", -1)); + return TCL_OK; + } + + /* Get tcl channel by name */ + Tcl_Channel channel = Tcl_GetChannel(interp, channelName, NULL); + if (channel == NULL) { + ePolicy_log_vs(EPOLICY_LOG_ERROR, vs_p, "tcp::recv: Invalid channel name"); + return TCL_ERROR; + } + + /* Get socket fd by TCL channle */ + ClientData sockfd; + Tcl_GetChannelHandle(channel, TCL_WRITABLE, &sockfd); + + struct timeval tv; + tv.tv_sec = 0; + tv.tv_usec = timeout_ms * 1000; + + fd_set readfds; + FD_ZERO(&readfds); + FD_SET((int)(intptr_t)sockfd, &readfds); + + /* Check if recv timeout */ + if (select((int)(intptr_t)sockfd + 1, &readfds, NULL, NULL, &tv) <= 0) { + ePolicy_log_vs(EPOLICY_LOG_ERROR, vs_p, "tcp::recv: timeout reached"); + Tcl_SetObjResult(interp, Tcl_NewStringObj("", -1)); + return TCL_OK; + } + + /* Read data */ + char data[MAX_BIN_MSG_SIZE]; + ssize_t bytes_received = recv(sockfd, data, sizeof(data) - 1, 0); + + /* Return recv data */ + Tcl_SetObjResult(interp, Tcl_NewStringObj(data, -1)); + + return TCL_OK; +} + +int tcp_close_conn(ClientData clientdata, Tcl_Interp *interp, int argc, Tcl_Obj *const argv[]) +{ + CHECK_FOR_COMPILE; + slb_vs_t *vs_p = (slb_vs_t *) Tcl_GetAssocData(interp, ASSOC_DATA_VS_ID, NULL); + + if(argc != 2) { + ePolicy_log_vs(EPOLICY_LOG_ERROR, vs_p, "%s: invalid param number: %d", __FUNCTION__, argc); + return TCL_ERROR; + } + + /* Get tcl channel by name */ + const char *channelName = Tcl_GetString(argv[1]); + + /* Because it hit the connection limit, channelName is "". */ + if (strcmp(channelName, "") == 0) { + return TCL_OK; + } + + Tcl_Channel channel = Tcl_GetChannel(interp, channelName, NULL); + if (channel == NULL) { + ePolicy_log_vs(EPOLICY_LOG_ERROR, vs_p, "tcp::close: Invalid channel name"); + return TCL_ERROR; + } + + /* Get socket fd by TCL channle */ + ClientData sockfd; + Tcl_GetChannelHandle(channel, TCL_WRITABLE, &sockfd); + + /* Close connection */ + close(sockfd); + + /* Close tcl channel */ + Tcl_UnregisterChannel(interp, channel); + + return TCL_OK; +} + int message_backup(ClientData clientdata, Tcl_Interp *interp, int argc, Tcl_Obj *const argv[]) { CHECK_FOR_COMPILE; @@ -864,6 +1300,10 @@ {"tcp::close_client_conn", tcp_close_client_conn, NULL}, {"tcp::reset_server_conn", tcp_reset_server_conn, NULL}, {"tcp::reset_client_conn", tcp_reset_client_conn, NULL}, + {"tcp::connect", tcp_open_conn, NULL}, + {"tcp::send", tcp_send_data, NULL}, + {"tcp::recv", tcp_recv_data, NULL}, + {"tcp::close", tcp_close_conn, NULL}, {"tcp::splice", tcp_splice_conn, NULL}, {"message::backup", message_backup, NULL}, {"application::finish_handshake", finish_handshake, NULL}, @@ -877,6 +1317,11 @@ void tcp_policy_init(ePolicy_engine_handle engine, ClientData clientdata) { + if (cpuid == atcp_L4_id_min) { + init_socket_queue_instance(&socket_long_limit_queue); + init_socket_queue_instance(&socket_mid_limit_queue); + init_socket_queue_instance(&socket_short_limit_queue); + } { const ePolicyCmdInfo *ePolicyCmdInfoPtr = NULL; //´´½¨TCP policyÃüÁ Index: /branches/rel_apv_10_7_2_5_irule/usr/click/lib/libuinet-atcp/lib/libuinet/uinet_api.symlist =================================================================== --- /branches/rel_apv_10_7_2_5_irule/usr/click/lib/libuinet-atcp/lib/libuinet/uinet_api.symlist (revision 38731) +++ /branches/rel_apv_10_7_2_5_irule/usr/click/lib/libuinet-atcp/lib/libuinet/uinet_api.symlist (working copy) @@ -381,10 +381,12 @@ http_status_code passive_http_timer_list hc_enable -vipstats -passive_hc_enable -force_sw_ssl -slb_proxy_protocol_v1_flags +vipstats +passive_hc_enable +force_sw_ssl +slb_proxy_protocol_v1_flags slb_proxy_protocol_v2_flags if_dpdk_set_ha_hb_port_if -diameter_config_shm_attach \ No newline at end of file +diameter_config_shm_attach +slb_rs_lookup +slb_rs_lookup6 \ No newline at end of file Index: /branches/rel_apv_10_7_2_5_irule/usr/click/lib/libuinet-atcp/lib/libuinet/uinet_host_kernelapi.c =================================================================== --- /branches/rel_apv_10_7_2_5_irule/usr/click/lib/libuinet-atcp/lib/libuinet/uinet_host_kernelapi.c (revision 38731) +++ /branches/rel_apv_10_7_2_5_irule/usr/click/lib/libuinet-atcp/lib/libuinet/uinet_host_kernelapi.c (working copy) @@ -612,6 +612,9 @@ if (events[i].data.fd == listen_fd) { bzero(&sun_n, sizeof(sun_n)); sl = sizeof(struct sockaddr_un); + + int retry = 0; +ns_accept_retry: ns = accept(listen_fd, (struct sockaddr *) &sun_n, &sl); ARRAY_DEBUG("kernel debug accept %d\n", ns); if (ns < 0) { @@ -619,10 +622,16 @@ } else { ARRAY_DEBUG("debug kapi_register_conn %d\n", ns); if (kapi_register_conn(ns) < 0) { - fprintf(stderr, "%s: kernelapi register conn failed: %d\n", __func__, errno); - /* if register epoll failed, close it*/ - close(ns); - continue; + if (retry < 3) { + fprintf(stderr, "%s: kernelapi register conn failed: %d, retry=%d\n", __func__, errno, retry); + retry++; + goto ns_accept_retry; + } else { + fprintf(stderr, "%s: kernelapi register conn failed: %d\n", __func__, errno); + /* if register epoll failed, close it*/ + close(ns); + continue; + } } } } else if (events[i].data.fd == fastlog_fd) { Index: /branches/rel_apv_10_7_2_5_irule/usr/click/lib/libuinet-atcp/lib/libuinet/uinet_if_dpdk.c =================================================================== --- /branches/rel_apv_10_7_2_5_irule/usr/click/lib/libuinet-atcp/lib/libuinet/uinet_if_dpdk.c (revision 38731) +++ /branches/rel_apv_10_7_2_5_irule/usr/click/lib/libuinet-atcp/lib/libuinet/uinet_if_dpdk.c (working copy) @@ -286,7 +286,8 @@ /* case 0: af_packet interface have no driver.*/ if (max_queue == -1) { - return (atcp_L4_nthreads/vm_ndomains); + /* Half of the total will retain the original ATCP L4 thread count. */ + return ((atcp_L4_nthreads >> 1)/vm_ndomains); } /* case 1: we have no chance to adjust queue number if max_queue is equal 1 */ @@ -295,13 +296,15 @@ } /* case 2: we have enough queues for all cores in a domain */ - if (max_queue >= (atcp_L4_nthreads/vm_ndomains)) { - return (atcp_L4_nthreads/vm_ndomains); + if (max_queue >= ((atcp_L4_nthreads >> 1)/vm_ndomains)) { + /* Half of the total will retain the original ATCP L4 thread count. */ + return ((atcp_L4_nthreads >> 1)/vm_ndomains); } /* case 3: 2 NIC's queues can use all cores in a domain */ - if ((max_queue*2) >= (atcp_L4_nthreads/vm_ndomains)) { - return (atcp_L4_nthreads/vm_ndomains)/2; + if ((max_queue*2) >= ((atcp_L4_nthreads >> 1)/vm_ndomains)) { + /* Half of the total will retain the original ATCP L4 thread count. */ + return ((atcp_L4_nthreads >> 1)/vm_ndomains)/2; } /* other case: no need to adjust max_queue */ @@ -319,7 +322,8 @@ if_dpdk_bind_port_queue(int port_id, int queue_num) { int i, domain, index, num; - int cpu_per_domain = atcp_L4_nthreads / vm_ndomains; + /* Half of the total will retain the original ATCP L4 thread count. */ + int cpu_per_domain = (atcp_L4_nthreads >> 1) / vm_ndomains; if (vm_ndomains > 1) { domain = if_dpdk_eth_domain_get(port_id); @@ -593,7 +597,8 @@ } if_dpdk_bind_port_queue(sc->port_id, rx_queue_num); - sc->dpdk_host_ctx = if_dpdk_create_if(sc->port_id, rx_queue_num, atcp_L4_nthreads / vm_ndomains, uif->type); + /* Half of the total will retain the original ATCP L4 thread count. */ + sc->dpdk_host_ctx = if_dpdk_create_if(sc->port_id, rx_queue_num, (atcp_L4_nthreads >> 1) / vm_ndomains, uif->type); if (sc->dpdk_host_ctx == NULL) { printf("create dpdk interface failed\n"); error = ENXIO; Index: /branches/rel_apv_10_7_2_5_irule/usr/click/lib/libuinet-atcp/lib/libuinet/uinet_if_dpdk_host.c =================================================================== --- /branches/rel_apv_10_7_2_5_irule/usr/click/lib/libuinet-atcp/lib/libuinet/uinet_if_dpdk_host.c (revision 38731) +++ /branches/rel_apv_10_7_2_5_irule/usr/click/lib/libuinet-atcp/lib/libuinet/uinet_if_dpdk_host.c (working copy) @@ -1991,7 +1991,8 @@ int if_dpdk_get_veth_queue_num() { - int qpairs = atcp_L4_nthreads / vm_ndomains; + /* Half of the total will retain the original ATCP L4 thread count. */ + int qpairs = (atcp_L4_nthreads >> 1) / vm_ndomains; if (qpairs == 0) { return 1; } Index: /branches/rel_apv_10_7_2_5_irule/usr/click/lib/libuinet-atcp/lib/libuinet/uinet_subr_smp.c =================================================================== --- /branches/rel_apv_10_7_2_5_irule/usr/click/lib/libuinet-atcp/lib/libuinet/uinet_subr_smp.c (revision 38731) +++ /branches/rel_apv_10_7_2_5_irule/usr/click/lib/libuinet-atcp/lib/libuinet/uinet_subr_smp.c (working copy) @@ -87,6 +87,9 @@ uint32_t atcp_L4_id_min; /* L4 thread minimum ATCP ID */ uint32_t atcp_L4_id_max; /* L4 thread maximum ATCP ID */ +uint32_t atcp_ePolicy_id_min; /* L4 special thread minimum ATCP ID for ePolicy*/ +uint32_t atcp_ePolicy_id_max; /* L4 special thread maximum ATCP ID for ePolicy*/ + SYSCTL_INT(_kern_smp, OID_AUTO, atcp_L4_id_min, CTLFLAG_RD, &atcp_L4_id_min, 0, "minimum L4 atcp thread number "); SYSCTL_INT(_kern_smp, OID_AUTO, atcp_L4_id_max, CTLFLAG_RD, &atcp_L4_id_max, 0, @@ -249,23 +252,39 @@ atcp_L4_id_max = atcp_L4_id_min + test_atcp_l4threads - 1; atcp_L4_nthreads = test_atcp_l4threads; + atcp_L7_id = atcp_L4_id_max; + + /* + * Double the L4 threads for ePolicy usage. + * atcp_L4_id_min atcp_L4_id_max + * |-----------------------------------------| + * |---------------------| + * atcp_ePolicy_id_min atcp_ePolicy_id_max + */ + atcp_ePolicy_id_min = atcp_L4_nthreads + atcp_L4_id_min; + atcp_ePolicy_id_max = atcp_L4_nthreads + atcp_L4_id_max; + atcp_L4_id_max = atcp_ePolicy_id_max; + + atcp_L4_nthreads += test_atcp_l4threads; + if ((atcp_L4_nthreads & (atcp_L4_nthreads - 1)) == 0) { atcp_L4_nthreads_mask = atcp_L4_nthreads - 1; } - atcp_L7_id = atcp_L4_id_max; - if (!atcp_L4_tq_int) { atcp_tq_id_min = atcp_L7_id + ATCP_L7_THREAD; atcp_tq_id_max = atcp_tq_id_min + test_atcp_taskqueues - 1; atcp_tq_nthreads = test_atcp_taskqueues; + atcp_tq_nthreads += test_atcp_taskqueues; } else { atcp_tq_id_min = atcp_L4_id_min; atcp_tq_id_max = atcp_L4_id_max; atcp_tq_nthreads = test_atcp_l4threads; + atcp_tq_nthreads += test_atcp_l4threads; } atcp_nthreads = ATCP_MANAGEMENT_THREAD + ATCP_IP_THREAD + test_atcp_l4threads + test_atcp_taskqueues; + atcp_nthreads += test_atcp_l4threads + test_atcp_taskqueues; /* enable by default */ if (getenv_string("ev_v4_enable", test_ev_v4_enable_str, Index: /branches/rel_apv_10_7_2_5_irule/usr/click/tools/nagelfar132/cmd_proxy.py =================================================================== --- /branches/rel_apv_10_7_2_5_irule/usr/click/tools/nagelfar132/cmd_proxy.py (revision 0) +++ /branches/rel_apv_10_7_2_5_irule/usr/click/tools/nagelfar132/cmd_proxy.py (working copy) @@ -0,0 +1,18 @@ +import os +import subprocess +import sys + +if len(sys.argv) < 2: + print("Usage: python cmd_proxy.py ") + sys.exit(1) + +last_param = sys.argv[1] + +os.chdir("/ca/bin/nagelfar132") +command = ["tclsh", "nagelfar_no_socket.tcl", last_param] + +try: + result = subprocess.check_output(command, stderr=subprocess.STDOUT) + print(result) +except subprocess.CalledProcessError as e: + print(e.output) \ No newline at end of file Index: /branches/rel_apv_10_7_2_5_irule/usr/click/tools/nagelfar132/epolicy.syntax =================================================================== --- /branches/rel_apv_10_7_2_5_irule/usr/click/tools/nagelfar132/epolicy.syntax (revision 38731) +++ /branches/rel_apv_10_7_2_5_irule/usr/click/tools/nagelfar132/epolicy.syntax (working copy) @@ -101,6 +101,10 @@ ##nagelfar syntax tcp::bypass_server_data ##nagelfar syntax tcp::splice x? ##nagelfar syntax tcp::option x x x? +##nagelfar syntax tcp::connect x x? +##nagelfar syntax tcp::send x x x? +##nagelfar syntax tcp::recv x x? +##nagelfar syntax tcp::close x ##nagelfar syntax application::finish_handshake Index: /branches/rel_apv_10_7_2_5_irule/usr/click/tools/nagelfar132/epolicy_no_socket.syntax =================================================================== --- /branches/rel_apv_10_7_2_5_irule/usr/click/tools/nagelfar132/epolicy_no_socket.syntax (revision 0) +++ /branches/rel_apv_10_7_2_5_irule/usr/click/tools/nagelfar132/epolicy_no_socket.syntax (working copy) @@ -0,0 +1,174 @@ +# This is a supplement to the source file nagelfar.tcl to provide +# extra syntax info for it. +# Whenever .tcl is checked, any .syntax is run through +# the syntax checker first. + +# Comments of the style below can be included in the source file +# or in a file like this if that is not suitable. + +# The syntax tokens (x/v/n etc.) are described in syntaxbuild.tcl +# More info can be found in the doc about inline comments. + + +# This procedure takes four arguments, the third being a call-by-name +# where the variable is set by the proc. The fourth is a call-by-name +# where the variable should exist before. + +##nagelfar syntax parseSubst x x n v + +# This procedure takes three arguments, the third being a +# call-by-name where the variable should exist before. + +##nagelfar syntax parseBody x x v x? + +# Argument 6 and 7 to markVariable is a call-by-name where +# the variable is set by this call and need not exist before. + +##nagelfar syntax markVariable x x x x x x n n + +# This application uses some package but since the standard database usually +# do not know about them, they are included here to avoid false warnings. + +##nagelfar syntax ctext::setHighlightTcl x +##nagelfar syntax textSearch::enableSearch x p* +##nagelfar option textSearch::enableSearch -label +##nagelfar option textSearch::enableSearch\ -label v +##nagelfar syntax textSearch::searchMenu x + + +##nagelfar syntax http::header x x? +##nagelfar syntax http::content_type x? +##nagelfar syntax http::cookie x x x? +##nagelfar syntax http::method +##nagelfar syntax http::version +##nagelfar syntax http::uri +##nagelfar syntax http::query_string x? x? +##nagelfar syntax http::status +##nagelfar syntax http::body x? +##nagelfar syntax http::respond x +##nagelfar syntax http::redirect x + + +##nagelfar syntax xml::elementname x? +##nagelfar syntax xml::stop_parse +##nagelfar syntax xml::attributes +##nagelfar syntax xml::attribute_rewrite x x +##nagelfar syntax xml::text +##nagelfar syntax xml::rewrite x? + + +##nagelfar syntax binary_message::payload x? +##nagelfar syntax binary_message::payload_free +##nagelfar syntax binary_message::send_to_server x x? +##nagelfar syntax binary_message::send_to_client x +##nagelfar syntax binary_message::send_to_servers x +##nagelfar syntax message::backup + + +##nagelfar syntax diameter::command +##nagelfar syntax diameter::is_request +##nagelfar syntax diameter::is_response + + +##nagelfar syntax slb::vs_is_active +##nagelfar syntax slb::select_server x +##nagelfar syntax slb::select_group x +##nagelfar syntax slb::group_is_active x +##nagelfar syntax slb::server_is_active x +##nagelfar syntax slb::active_members x +##nagelfar syntax slb::server +##nagelfar syntax slb::create_table x x x +##nagelfar syntax slb::insert_table x x x +##nagelfar syntax slb::lookup_table x x +##nagelfar syntax slb::tag_conn_table x x +##nagelfar syntax slb::tag_conn x x +##nagelfar syntax slb::use_tag_conn x +##nagelfar syntax slb::get_current_conn x +##nagelfar syntax slb::snatpool x x? x? + + +##nagelfar syntax ip::client_addr x? +##nagelfar syntax ip::client_port +##nagelfar syntax ip::server_addr x? +##nagelfar syntax ip::server_port + + +##nagelfar syntax tcp::is_server_conn +##nagelfar syntax tcp::reset_client_conn x? +##nagelfar syntax tcp::reset_server_conn x? +##nagelfar syntax tcp::close_client_conn +##nagelfar syntax tcp::close_server_conn +##nagelfar syntax tcp::bypass_server_data +##nagelfar syntax tcp::splice x? +##nagelfar syntax tcp::option x x x? +##nagelfar syntax application::finish_handshake +# Copy epolicy.syntax and comment out the socket-related functions for testing purposes. +# ##nagelfar syntax tcp::connect x x? +# ##nagelfar syntax tcp::send x x x? +# ##nagelfar syntax tcp::recv x x? +# ##nagelfar syntax tcp::close x + + +##nagelfar syntax md5 x +##nagelfar syntax b64encode x +##nagelfar syntax clock_seconds +##nagelfar syntax userdata x x +##nagelfar syntax log x +##nagelfar syntax read_list_from_file x x? +##nagelfar syntax cli x +##nagelfar syntax ldapupdate x x x x x x x + + +##nagelfar syntax message::type x +##nagelfar syntax binary_message::length_start_offset x +##nagelfar syntax binary_message::length_end_offset x +##nagelfar syntax binary_message::length_ascii_encoding +##nagelfar syntax binary_message::length_little_endian +##nagelfar syntax binary_message::parser x +##nagelfar syntax binary_message::header_length x +##nagelfar syntax application::mode x x? +##nagelfar syntax application::need_handshake +##nagelfar syntax application::one_connection +##nagelfar syntax application::create_server_conn x +##nagelfar syntax application::is_drop_resp + + +##nagelfar syntax atimer::add x x +##nagelfar syntax timer::remove x +##nagelfar syntax timer::id + + +##nagelfar syntax udp::payload x x x x +##nagelfar syntax udp::drop +##nagelfar syntax uudp::respond x +##nagelfar syntax udp::local_port x +##nagelfar syntax udp::remote_port x +##nagelfar syntax udp::mss + + +##nagelfar syntax ssl::cert x x? x? +##nagelfar syntax ssl::cipher x +##nagelfar syntax ssl::clientrandom +##nagelfar syntax ssl::extension x x? x? +##nagelfar syntax ssl::is_renegotiation_secure +##nagelfar syntax ssl::sessionid +##nagelfar syntax ssl::modssl_sessionid_headers x? +##nagelfar syntax ssl::sni_name +##nagelfar syntax ssl::sessionsecret +##nagelfar syntax ssl::sessionticket +##nagelfar syntax ssl::verify_result +##nagelfar syntax ssl::remove_sessionid + + +##nagelfar syntax unionpay8583::parse x +##nagelfar syntax binary_message::send_heartbeat x +##nagelfar syntax slb::get_client_conn +##nagelfar syntax slb::get_server_conn x +##nagelfar syntax mysql::calc_passwd x x + + +##nagelfar syntax binary_message::is_http +##nagelfar syntax orch::chainname +##nagelfar syntax orch::devicename +##nagelfar syntax orch::servicename +##nagelfar syntax orch::direction \ No newline at end of file Index: /branches/rel_apv_10_7_2_5_irule/usr/click/tools/nagelfar132/nagelfar.syntax =================================================================== --- /branches/rel_apv_10_7_2_5_irule/usr/click/tools/nagelfar132/nagelfar.syntax (revision 38731) +++ /branches/rel_apv_10_7_2_5_irule/usr/click/tools/nagelfar132/nagelfar.syntax (working copy) @@ -99,6 +99,10 @@ ##nagelfar syntax tcp::bypass_server_data ##nagelfar syntax tcp::splice x? ##nagelfar syntax tcp::option x x x? +##nagelfar syntax tcp::connect x x? +##nagelfar syntax tcp::send x x x? +##nagelfar syntax tcp::recv x x? +##nagelfar syntax tcp::close x ##nagelfar syntax application::finish_handshake Index: /branches/rel_apv_10_7_2_5_irule/usr/click/tools/nagelfar132/nagelfar_no_socket.tcl =================================================================== --- /branches/rel_apv_10_7_2_5_irule/usr/click/tools/nagelfar132/nagelfar_no_socket.tcl (revision 0) +++ /branches/rel_apv_10_7_2_5_irule/usr/click/tools/nagelfar132/nagelfar_no_socket.tcl (working copy) @@ -0,0 +1,7305 @@ +#!/bin/sh +# the next line restarts using tclsh \ +exec tclsh "$0" "$@" + +#---------------------------------------------------------------------- +# Nagelfar, a syntax checker for Tcl. +# Copyright (c) 1999-2015, Peter Spjuth +# +# This program is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 2 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program; see the file COPYING. If not, write to +# the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +# Boston, MA 02111-1307, USA. +# +#---------------------------------------------------------------------- +# prologue.tcl +#---------------------------------------------------------------------- +# 5c8c01c31be8961c254ba8d56e7e92fb832dd358 +#---------------------------------------------------------------------- + +set debug 0 +package require Tcl 8.5 + +package provide app-nagelfar 1.0 +# This variable should be overwritten by the build process +set version "Version ??? ???" + +# Allow thisScript to be predefined (used for test) +if {![info exists thisScript]} { + set thisScript [file normalize [file join [pwd] [info script]]] +} +set thisDir [file dirname $thisScript] + +# Follow any link +set tmplink $thisScript +while {[file type $tmplink] == "link"} { + set tmplink [file readlink $tmplink] + set tmplink [file normalize [file join $thisDir $tmplink]] + set thisDir [file dirname $tmplink] +} +unset tmplink + +# This makes it possible to customize where files are installed +set dbDir $thisDir +set docDir $thisDir/doc +set libDir $thisDir/lib + +# Search where the script is, to be able to place e.g. ctext there. +if {[info exists ::starkit::topdir]} { + lappend auto_path [file dirname [file normalize $::starkit::topdir]] +} else { + lappend auto_path $libDir +} +set version "Version 1.3.2 2021-02-02" +#---------------------------------------------------------------------- +# Nagelfar, a syntax checker for Tcl. +# Copyright (c) 1999-2010, Peter Spjuth +# +# This program is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 2 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program; see the file COPYING. If not, write to +# the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +# Boston, MA 02111-1307, USA. +# +#---------------------------------------------------------------------- +# nagelfar.tcl +#---------------------------------------------------------------------- + +# TODO: Make it possible to put a global var type in syntax file. +##nagelfar variable ::Nagelfar(resultWin) _obj,text + +##################### +# Syntax check engine +##################### + +# Arguments to many procedures: +# index : Index of the start of a string or command. +# cmd : Command +# argv : List of arguments +# wordstatus: List of status for the words in argv +# indices : List of indices where every word in argv starts +# knownVars : A dict that keeps track of variables known in this scope + +# Interpretation of wordstatus: +# 1 constant +# 2 braced +# 4 quoted +# 8 {*}-expanded + +# Interpretation of knownVars: +# Each key is a variable name, with a dict with the following possible fields: +# knownVars $var : Existance means variable is known to exist. +# knownVars $var local : Variable is local in a procedure. +# knownVars $var set : A set of this variable has been seen. +# knownVars $var read : A read of this variable seen before any set. +# knownVars $var used : A read of this variable seen. +# knownVars $var type : The variable's type if known. +# knownVars $var array : The variable is an array +# knownVars $var namespace : Variable belongs to this namespace. (unless local) +# knownVars $var upvar : Variable is upvared from this variable. + +# Helper to initialise a knownVars element to defaults. +# This helps make sure all fields that must exist do +proc knownVar {knownVarsName var} { + upvar $knownVarsName knownVars + dict set knownVars $var local 0 + dict set knownVars $var set 0 + dict set knownVars $var read 0 + dict set knownVars $var used 0 + dict set knownVars $var type "" + # The array field can be unknown or boolean + dict set knownVars $var array "" + dict set knownVars $var namespace "" + dict set knownVars $var upvar "" +} + +# Moved out message handling to make it more flexible +proc echo {str {tag {}}} { + if {[info exists ::Nagelfar(resultWin)]} { + if {$tag == 1} { + set tag info + } + $::Nagelfar(resultWin) configure -state normal + $::Nagelfar(resultWin) insert end $str\n $tag + $::Nagelfar(resultWin) configure -state disabled + } elseif {$::Nagelfar(embedded)} { + lappend ::Nagelfar(chkResult) $str + } else { + puts stdout $str + } + update +} + +# Debug output +proc decho {str} { + if {[info exists ::Nagelfar(resultWin)]} { + $::Nagelfar(resultWin) configure -state normal + $::Nagelfar(resultWin) insert end $str\n error + $::Nagelfar(resultWin) configure -state disabled + } else { + puts stderr $str + } + update +} + +# Error message from program, not from syntax check +proc errEcho {msg} { + if {$::Nagelfar(gui)} { + tk_messageBox -title "Nagelfar Error" -type ok -icon error \ + -message $msg + } else { + puts stderr $msg + } +} + +# Add html quiting on a string +proc Text2Html {data} { + string map {\& \& \< \< \> \> \" \"} $data +} + +# Moved out of errorMsg so message and line-filter use the same +# text +proc errorMsgLinePrefix {line appendStr} { + set pre "" + if {$::currentFile != ""} { + set pre "$::currentFile: " + } + if {$::Prefs(prefixFile)} { + # Use a shorter format when -H flag is used + # This format can be parsed by e.g. emacs compile + set pre "${pre}$line: " + } else { + set pre "${pre}Line [format %3d $line]: " + } + return $pre$appendStr +} + +# Standard error message. +# severity : How severe a message is E/W/N for Error/Warning/Note +proc errorMsg {severity msg i {notAllowedinFirst 0}} { + #echo "$msg" + if {$::Prefs(html)} { + set htmlMsg [Text2Html $msg] + if {$msg == "Expr without braces"} { + append htmlMsg " (see http://tclhelp.net/unb/194)" + } + } + + if {[info exists ::Nagelfar(currentMessage)] && \ + $::Nagelfar(currentMessage) != ""} { + lappend ::Nagelfar(messages) [list $::Nagelfar(currentMessageLine) \ + $::Nagelfar(currentMessage) $::Nagelfar(currentHtmlMessage)] + } + + set ::Nagelfar(currentMessage) "" + set ::Nagelfar(currentHtmlMessage) "" + # Stop some messages in first pass + if {$::Nagelfar(firstpass) && $notAllowedinFirst} { + return + } + switch $severity { + E {} + W { if {$::Prefs(severity) == "E"} return } + N { if {$::Prefs(severity) != "N"} return } + default { + decho "Internal error: Bad severity '$severity' passed to errorMsg" + return + } + } + + set line [calcLineNo $i] + set pre [errorMsgLinePrefix $line "$severity "] + if {$::Prefs(html)} { + switch $severity { + E { set color "#DD0000"; set severityMsg "ERROR" } + W { set color "#FFAA00"; set severityMsg "WARNING" } + N { set color "#66BB00"; set severityMsg "NOTICE" } + } + set htmlPre "Line [format %3d $line]: $severityMsg: " + set ::Nagelfar(currentHtmlMessage) $htmlPre$htmlMsg + } + + set ::Nagelfar(indent) [string repeat " " [string length $pre]] + set ::Nagelfar(currentMessage) $pre$msg + set ::Nagelfar(currentMessageLine) $line +} + +# Continued message. Used to give extra info after an error. +proc contMsg {msg {i {}}} { + if {$::Nagelfar(currentMessage) == ""} return + append ::Nagelfar(currentMessage) "\n" $::Nagelfar(indent) + if {$i != ""} { + regsub -all {%L} $msg [calcLineNo $i] msg + } + append ::Nagelfar(currentMessage) $msg + if {$::Prefs(html)} { + append ::Nagelfar(currentHtmlMessage) [Text2Html $msg] + } +} + +# Initialize message handling. +proc initMsg {} { + set ::Nagelfar(messages) {} + set ::Nagelfar(currentMessage) "" + set ::Nagelfar(currentHtmlMessage) "" + set ::Nagelfar(commentbrace) {} +} + +# Called after a file has been parsed, to flush messages +proc flushMsg {} { + if {[info exists ::Nagelfar(currentMessage)] && \ + $::Nagelfar(currentMessage) != ""} { + lappend ::Nagelfar(messages) [list $::Nagelfar(currentMessageLine) \ + $::Nagelfar(currentMessage) $::Nagelfar(currentHtmlMessage)] + } + + set msgs [lsort -integer -index 0 $::Nagelfar(messages)] + + foreach msg $msgs { + set line [lindex $msg 0] + set text [lindex $msg 1] + set print 1 + foreach filter $::Nagelfar(filter) { + lassign $filter pat start_line end_line + if {$start_line > 0} { + # line specific filter + if {$line >= $start_line && $line <= $end_line} { + set final_pat [errorMsgLinePrefix $line $pat] + if {[string match $final_pat $text]} { + set print 0 + } + } + } else { + # general filter + if {[string match $pat $text]} { + set print 0 + break + } + } + } + if {$print} { + incr ::Nagelfar(messageCnt) + if {$::Prefs(html)} { + echo [lindex $msg 2] message$::Nagelfar(messageCnt) + } else { + echo [lindex $msg 1] message$::Nagelfar(messageCnt) + } + if {$::Nagelfar(exitstatus) < 2 && [string match "*: E *" $msg]} { + set ::Nagelfar(exitstatus) 2 + } elseif {$::Nagelfar(exitstatus) < 1 && [string match "*: W *" $msg]} { + set ::Nagelfar(exitstatus) 1 + } + } + } + initMsg +} + +# Report any unbalanced braces in comments that have been noticed +proc reportCommentBrace {fromIx toIx} { + set fromLn [calcLineNo $fromIx] + set toLn [calcLineNo $toIx] + set new {} + foreach {n lineNo} $::Nagelfar(commentbrace) { + if {$fromLn <= $lineNo && $lineNo <= $toLn} { + contMsg "Unbalanced brace in comment in line $lineNo." + } else { + lappend new $n $lineNo + } + } + # Only report it once + set ::Nagelfar(commentbrace) $new +} + +# Trim a string to fit within a length. +proc trimStr {str {len 10}} { + set str [string trim $str] + if {[string length $str] > $len} { + set str [string range $str 0 [expr {$len - 4}]]... + } + return $str +} + +# Test for comments with unmatched braces. +proc checkPossibleComment {str lineNo} { + # Count braces + set n1 [llength [split $str \{]] + set n2 [llength [split $str \}]] + if {$n1 != $n2} { + lappend ::Nagelfar(commentbrace) [expr {$n1 - $n2}] $lineNo + } +} + +# Copy the syntax from one command to another +proc CopyCmdInDatabase {from to {map {}}} { + foreach arrName {::syntax ::return ::subCmd ::option} { + upvar 0 $arrName arr + foreach item [array names arr] { + if {$item eq $from} { + # Handle overwrite? + if {[info exists arr($to)]} { + if {$arrName eq "::subCmd"} { + # Add to a subcommand list + set arr($to) [lsort -unique [concat $arr($to) $arr($item)]] + } else { + # FIXA? + #echo "$::Nagelfar(firstpass) $from $to $arrName $item" + } + } else { + #echo "Copy $from $to $arrName $item" + set arr($to) [string map $map $arr($item)] + } + } else { + set len [expr {[string length $from] + 1}] + if {[string equal -length $len $item "$from "]} { + set to2 "$to [string range $item $len end]" + set arr($to2) [string map $map $arr($item)] + } + } + } + } + lappend ::knownCommands $to +} + +# This is called when a comment is encountered. +# It allows syntax information to be stored in comments +proc checkComment {str index knownVarsName} { + upvar $knownVarsName knownVars + + # Support Frink's inline comment + if {[regexp {\#\s*(FRINK|PRAGMA):\s*nocheck} $str -> keyword]} { + set line [calcLineNo $index] + incr line + addFilter "*" $line $line + return + } + + # We only care about this pattern + if {![string match "##nagelfar *" $str]} { + return + } + + set commentList [string range $str 11 end] + if {[catch {llength $commentList}]} { + errorMsg N "Bad list in ##nagelfar comment" $index 1 + return + } + if {[llength $commentList] == 0} return + set cmd [lindex $commentList 0] + + # Let plugins see comments and define additional ones + set pluginComment [pluginHandleComment $cmd [lrange $commentList 1 end]] + if {$pluginComment} { + # Plugin specific action + return + } + + set first [lindex $commentList 1] + set rest [lrange $commentList 2 end] + + switch -- $cmd { + syntax { + # decho "Syntax for '$first' : '$rest'" + set ::syntax($first) $rest + lappend ::knownCommands $first + } + implicitvarns { + set ::implicitVarNs($first) $rest + } + implicitvarns+ { + lappend ::implicitVarNs($first) {*}$rest + } + implicitvarcmd { + set ::implicitVarCmd($first) $rest + } + implicitvarcmd+ { + lappend ::implicitVarCmd($first) {*}$rest + } + return { + set ::return($first) $rest + } + subcmd { + set ::subCmd($first) $rest + } + subcmd+ { + lappend ::subCmd($first) {*}$rest + } + package { + if {$first eq "known"} { + lappend ::knownPackages {*}$rest + } elseif {$first eq "require"} { + lookForPackageDb $rest $index + } else { + errorMsg N "Bad type in ##nagelfar comment" $index 1 + } + } + option { + set ::option($first) $rest + } + option+ { + lappend ::option($first) {*}$rest + } + variable { + set type [join $rest] + markVariable $first 1 "" 1n $index unknown knownVars type + } + vartype { + # Just mark the type on an existing variable + # This cannot be done during the first pass when variables + # are not fully handled + if {!$::Nagelfar(firstpass)} { + set type [join $rest] + setVariableType $first $type $index knownVars + } + } + alias { + set ::knownAliases($first) $rest + } + nspath { + if {$first eq "current"} { + set first [currentNamespace] + } + lappend ::namespacePath($first) {*}$rest + } + copy { + #echo "Copy in $::Nagelfar(firstpass) $first [lindex $rest 0]" + CopyCmdInDatabase $first [lindex $rest 0] [lrange $rest 1 end] + } + nocover { + set ::instrumenting(no,$index) 1 + } + cover { + if {$first ne "variable"} { + + } else { + set varname [lindex $rest 0] + set ::instrumenting($index) [list var $varname] + } + } + ignore - + filter { + set line [calcLineNo $index] + if {[regexp {^\+\d+$} $first]} { + # Allow an offset to ignore a line further down + incr line $first + incr line_to $line + set first [lindex $rest 0] + set rest [lrange $rest 1 end] + } elseif {[regexp {^\#(\d+)$} $first dummy range]} { + # Allow a range of lines to ignore + incr line + incr line_to [expr {$line + $range - 1}] + set first [lindex $rest 0] + set rest [lrange $rest 1 end] + } else { + incr line + incr line_to $line + } + switch -- $first { + N { addFilter "N *[join $rest]*" $line $line_to } + W { addFilter "\[NW\] *[join $rest]*" $line $line_to } + E { addFilter "*[join $rest]*" $line $line_to } + default { addFilter "*$first [join $rest]*" $line $line_to } + } + } + varused { + setVarUsed knownVars $first + } + default { + errorMsg N "Bad type in ##nagelfar comment" $index 1 + return + } + } +} + +# Handle a stack of current namespaces. +proc currentNamespace {} { + lindex $::Nagelfar(namespaces) end +} + +proc pushNamespace {ns} { + lappend ::Nagelfar(namespaces) $ns +} + +proc popNamespace {} { + set ::Nagelfar(namespaces) [lrange $::Nagelfar(namespaces) 0 end-1] +} + +# Handle a stack of current procedures. +proc currentProc {} { + lindex $::Nagelfar(procs) end +} + +proc pushProc {p} { + lappend ::Nagelfar(procs) $p +} + +proc popProc {} { + set ::Nagelfar(procs) [lrange $::Nagelfar(procs) 0 end-1] +} + +# Handle a current object. +proc currentObject {} { + return [lindex $::Nagelfar(object) 0] +} + +proc currentObjectOrig {} { + return [lindex $::Nagelfar(object) 1] +} + +proc setCurrentObject {objname name} { + set ::Nagelfar(object) [list $objname $name] +} + +# Return the index of the first non whitespace char following index "i". +proc skipWS {str len i} { + set j [string length [string trimleft [string range $str $i end]]] + return [expr {$len - $j}] +} + +# Scan the string until the end of one word is found. +# When entered, i points to the start of the word. +# Returns the index of the last char of the word. +proc scanWord {str len index i} { + set si1 $i + set si2 $i + set c [string index $str $i] + + if {$c eq "\{"} { + if {[string range $str $i [expr {$i + 2}]] eq "{*}"} { + set ni [expr {$i + 3}] + set nc [string index $str $ni] + if {![string is space $nc]} { + # Non-space detected, it is expansion + set c $nc + set i $ni + set si2 $i + } else { + errorMsg N "Standalone {*} can be confused with argument expansion. I recommend \"*\"." $index + } + } + } + + if {$c eq "\{"} { + set closeChar \} + set charType brace + } elseif {$c eq "\""} { + set closeChar \" + set charType quote + } else { + set closeChar "" + } + + if {$closeChar ne ""} { + for {} {$i < $len} {incr i} { + # Search for closeChar + set i [string first $closeChar $str $i] + if {$i == -1} { + # This should never happen since no incomplete lines should + # reach this function. + decho "Internal error: Did not find close char in scanWord.\ + Line [calcLineNo $index]." + return $len + } + set word [string range $str $si2 $i] + if {[info complete $word]} { + # Check for following whitespace + set j [expr {$i + 1}] + set nextchar [string index $str $j] + if {$j == $len || [string is space $nextchar]} { + return $i + } + errorMsg E "Extra chars after closing $charType." \ + [expr {$index + $i}] + contMsg "Opening $charType of above was on line %L." \ + [expr {$index + $si2}] + # Extra info for this particular case + if {$charType eq "brace" && $nextchar eq "\{"} { + contMsg "It might be a missing space between \} and \{" + } + # Switch over to scanning for whitespace + incr i + break + } + } + } + + for {} {$i < $len} {incr i} { + # Search for unescaped whitespace + if {[regexp -start $i -indices {(^|[^\\])(\\\\)*\s} $str match]} { + set i [lindex $match 1] + } else { + set i $len + } + # any word starting with # will not work correctly in info + # complete, but by prepending the string with "x " it works + if {[info complete "x [string range $str $si2 $i]"]} { + return [expr {$i - 1}] + } + } + + # Theoretically, no incomplete string should come to this function, + # but some precaution is never bad. + if {![info complete [string range $str $si2 end]]} { + decho "Internal error in scanWord: String not complete.\ + Line [calcLineNo [expr {$index + $si1}]]." + decho $str + return -code break + } + return [expr {$i - 1}] +} + +# Split a statement into words. +# Returns a list of the words, and puts a list with the indices +# for each word in indicesName. +proc splitStatement {statement index indicesName} { + upvar $indicesName indices + set indices {} + + set len [string length $statement] + if {$len == 0} { + return {} + } + set words {} + set i 0 + # There should not be any leading whitespace in the string that + # reaches this function. Check just in case. + set i [skipWS $statement $len $i] + if {$i != 0 && $i < $len} { + decho "Internal error:" + decho " Whitespace in splitStatement. [calcLineNo $index]" + } + # Comments should be descarded earlier + if {[string index $statement $i] eq "#"} { + decho "Internal error:" + decho " A comment slipped through to splitStatement. [calcLineNo $index]" + return {} + } + while {$i < $len} { + set si $i + lappend indices [expr {$i + $index}] + set i [scanWord $statement $len $index $i] + lappend words [string range $statement $si $i] + incr i + set i [skipWS $statement $len $i] + } + return $words +} + +# FIXA Options may be non constant. + +# Look for options in a command's arguments. +# Check them against the list in the option database, if any. +# Returns a syntax string corresponding to the number of arguments "used". +# If 'pair' is set, all options should take a value. +proc checkOptions {cmd argv wordstatus indices wordtype startI max pair} { + global option + ##nagelfar cover variable max + + # Special case: the first option is "--" + if {[lindex $argv $startI] == "--"} { + # Allowed? + set ix [lsearch -exact $option($cmd) --] + if {$ix >= 0} { + return [list x] + } + } + + # How many is the limit imposed by the number of arguments? + set maxArgs [expr {[llength $argv] - $startI}] + + # Pairs swallow an even number of args. + set extraAfterPair 0 + if {$pair && ($maxArgs % 2) == 1} { + # If the odd one is "--", it may continue + if {[lindex $argv [expr {$startI + $maxArgs - 1}]] == "--" && \ + [lsearch -exact $option($cmd) --] >= 0} { + # Nothing + } else { + set extraAfterPair 1 + incr maxArgs -1 + } + } + + if {$max == 0 || $maxArgs < $max} { + set max $maxArgs + } + if {$maxArgs == 0} { + return {} + } + set check [info exists option($cmd)] + if {!$check && $::Nagelfar(dbpicky)} { + errorMsg N "DB: Missing options for command \"$cmd\"" 0 + } + set i 0 + set used 0 + set skip 0 + set skipSyn x + set replaceSyn {} + # Since in most cases startI is 0, I believe foreach is faster. + foreach arg $argv ws $wordstatus index $indices wType $wordtype { + if {$i < $startI} { + incr i + continue + } + if {$skip} { + set skip 0 + lappend replaceSyn $skipSyn + set skipSyn x + incr used + continue + } + if {$max != 0 && $used >= $max} { + # A special check to give a nicer message when there is + # a missing value among pairs. + if {$extraAfterPair} { + if {($ws & 1) && $check} { + set ix [lsearch -exact $option($cmd) $arg] + if {$ix >= 0} { + set skip 1 + } + } + } + break + } + if {[string match "-*" $arg]} { + incr used + lappend replaceSyn x + set skip $pair + if {($ws & 1) && $check} { # Constant + set ix [lsearch -exact $option($cmd) $arg] + if {$ix == -1} { + # Check ambiguity. + if {![regexp {[][?*]} $arg]} { + # Only try globbing if $arg is free from glob chars. + set match [lsearch -all -inline -glob $option($cmd) $arg*] + } else { + set match {} + } + if {[llength $match] == 0} { + errorMsg E "Bad option $arg to \"$cmd\"" $index + set item "" + } elseif {[llength $match] > 1} { + errorMsg E "Ambigous option for \"$cmd\",\ + $arg -> [join $match /]" $index + set item "" + } else { + errorMsg W "Shortened option for \"$cmd\",\ + $arg -> [lindex $match 0]" $index + + set item "$cmd [lindex $match 0]" + } + } else { + set item "$cmd [lindex $option($cmd) $ix]" + } + if {$item ne ""} { + if {[info exists option($item)]} { + set skip 1 + if {[regexp {^[lnvc]$} $option($item)]} { + set skipSyn $option($item) + } + } + } + } + if {$arg eq "--"} { + set skip 0 + break + } + } else { # If not -* + if {$pair && ($ws & 8)} { + # We accept an argument expansion were a pair is expected. + # Communicate using a special token + lappend replaceSyn X + # Adjust since we ate an odd argument + if {$extraAfterPair} { + set extraAfterPair 0 + incr max + } else { + set extraAfterPair 1 + incr max -1 + } + continue + } elseif {$max == 1 && ($ws & 8)} { + # Special case to allow expansion with "o." + lappend replaceSyn x + } elseif {$wType eq "option"} { + if {$ws & 8} { + # Communicate using a special token + lappend replaceSyn X + } else { + lappend replaceSyn x + } + continue + } + break + } + } + if {$skip} { + errorMsg E "Missing value for last option." $index + } + #decho "options to $cmd : $replaceSyn" + return $replaceSyn +} + +# Make a list of a string. This is easy, just treat it as a list. +# But we must keep track of indices, so our own parsing is needed too. +proc splitList {str index iName wsName} { + upvar $iName indices $wsName wordstatuses + + # Make a copy to perform list operations on + set lstr [string range $str 0 end] + + set indices {} + set wordstatuses {} + if {[catch {set n [llength $lstr]}]} { + errorMsg E "Bad list" $index + return {} + } + # Parse the string to get indices for each element + set escape 0 + set level 0 + set len [string length $str] + set state whsp + + for {set i 0} {$i < $len} {incr i} { + set c [string index $str $i] + switch -- $state { + whsp { # Whitespace + if {[string is space $c]} continue + # End of whitespace, i.e. a new element + if {$c eq "\{"} { + set level 1 + set state brace + lappend indices [expr {$index + $i + 1}] + lappend wordstatuses 3 + } elseif {$c eq "\""} { + set state quote + lappend indices [expr {$index + $i + 1}] + lappend wordstatuses 5 + } else { + if {$c eq "\\"} { + set escape 1 + } + set state word + lappend indices [expr {$index + $i}] + lappend wordstatuses 1 + } + } + word { + if {$c eq "\\"} { + set escape [expr {!$escape}] + } else { + if {!$escape} { + if {[string is space $c]} { + set state whsp + continue + } + } else { + set escape 0 + } + } + } + quote { + if {$c eq "\\"} { + set escape [expr {!$escape}] + } else { + if {!$escape} { + if {$c eq "\""} { + set state whsp + continue + } + } else { + set escape 0 + } + } + } + brace { + if {$c eq "\\"} { + set escape [expr {!$escape}] + } else { + if {!$escape} { + if {$c eq "\{"} { + incr level + } elseif {$c eq "\}"} { + incr level -1 + if {$level <= 0} { + set state whsp + } + } + } else { + set escape 0 + } + } + } + } + } + + if {[llength $indices] != $n} { + # This should never happen. + decho "Internal error: Length mismatch in splitList.\ + Line [calcLineNo $index]." + decho "nindices: [llength $indices] nwords: $n" +# decho :$str: + foreach l $lstr ix $indices { + decho :$ix:[string range $l 0 10]: + } + } + return $lstr +} + +# Parse a variable name, check for existence +# This is called when a $ is encountered +# "i" points to the first char after $ +# Returns the type of the variable +proc parseVar {str len index iName knownVarsName} { + upvar $iName i $knownVarsName knownVars + set si $i + set c [string index $str $si] + + if {$c eq "\{"} { + # A variable ref starting with a brace always ends with next brace, + # no exceptions that I know of + incr si + set ei [string first "\}" $str $si] + if {$ei == -1} { + # This should not happen. + errorMsg E "Could not find closing brace in variable reference." \ + $index + } + set i $ei + incr ei -1 + set var [string range $str $si $ei] + set vararr 0 + # check for an array + if {[string index $str $ei] eq ")"} { + set pi [string first "(" $str $si] + if {$pi != -1 && $pi < $ei} { + incr pi -1 + set var [string range $str $si $pi] + incr pi 2 + incr ei -1 + set varindex [string range $str $pi $ei] + set vararr 1 + set varindexconst 1 + } + } + } else { + for {set ei $si} {$ei < $len} {incr ei} { + set c [string index $str $ei] + if {[string is wordchar $c]} continue + # :: is ok. + if {$c eq ":"} { + set c [string index $str [expr {$ei + 1}]] + if {$c eq ":"} { + incr ei + continue + } + } + break + } + if {[string index $str $ei] eq "("} { + # Locate the end of the array index + set pi $ei + set apa [expr {$si - 1}] + while {[set ei [string first ")" $str $ei]] != -1} { + if {[info complete [string range $str $apa $ei]]} { + break + } + incr ei + } + if {$ei == -1} { + # This should not happen. + errorMsg E "Could not find closing parenthesis in variable\ + reference." $index + return + } + set i $ei + incr pi -1 + set var [string range $str $si $pi] + incr pi 2 + incr ei -1 + set varindex [string range $str $pi $ei] + set vararr 1 + set varindexconst [parseSubst $varindex \ + [expr {$index + $pi}] type knownVars] + } else { + incr ei -1 + set i $ei + set var [string range $str $si $ei] + set vararr 0 + } + } + + # By now: + # var is the variable name + # vararr is 1 if it is an array + # varindex is the array index + # varindexconst is 1 if the array index is a constant + + if {$var == ""} { + return "" + } + + # Allow a plugin to have a look at the variable read + if {$::Nagelfar(pluginVarRead)} { + pluginHandleVarRead var knownVars $index + } + setVarUsed knownVars $var + if {$vararr} { + setVarUsed knownVars $var\($varindex\) + } + + if {[string match ::* $var]} { + # Skip qualified names until we handle namespace better. FIXA + # Handle types for constant names + if {!$vararr} { + set full $var + } elseif {$varindexconst} { + set full ${var}($varindex) + } else { + set full "" + } + if {$full ne "" && [dict exists $knownVars $full]} { + return [dict get $knownVars $full "type"] + } + return "" + } + # FIXA: Use markVariable + if {[dict exists $knownVars $var] && + [dict get $knownVars $var array] ne ""} { + if {$vararr != [dict get $knownVars $var array]} { + if {$vararr} { + errorMsg E "Is array, was scalar" $index + } else { + errorMsg E "Is scalar, was array" $index + } + } + } + if {![dict exists $knownVars $var] && !$::Prefs(noVar)} { + if {[string match "*::*" $var]} { + set tail [namespace tail $var] + set ns [namespace qualifiers $var] + #decho "'$var' '$ns' '$tail'" + if {![dict exists $knownVars $tail] || \ + [dict get $knownVars $tail local] || \ + ([dict get $knownVars $tail namespace] ne $ns && \ + [dict get $knownVars $tail namespace] ne "::$ns")} { + if {[currentProc] eq ""} { + # We cannot check namespace variables in a proc. + # TBD: Can we ever? + errorMsg E "Unknown variable \"$var\"" $index 1 + } + } + } else { + errorMsg E "Unknown variable \"$var\"" $index 1 + } + } + if {[dict exists $knownVars $var] && ![dict get $knownVars $var set]} { + # It was read before it was set (within this scope) + dict set knownVars $var read 1 + } + if {$vararr && [dict exists $knownVars $var\($varindex\)] && + [dict get $knownVars $var\($varindex\) "type"] ne ""} { + return [dict get $knownVars $var\($varindex\) "type"] + } + if {[dict exists $knownVars $var] && + [dict get $knownVars $var "type"] ne ""} { + return [dict get $knownVars $var "type"] + } + return "" + # Make use of markVariable. FIXA + # If it's a constant array index, maybe it should be checked? FIXA +} + +# Check for substitutions in a word +# Check any variables referenced, and parse any commands within brackets. +# Returns 1 if the string is constant, i.e. no substitutions +# Returns 0 if any substitutions are present +proc parseSubst {str index typeName knownVarsName} { + upvar $typeName type $knownVarsName knownVars + + set type "" + + # First do a quick check for $ or [ + # If the word ends in "]" and there is no "[" it is considered + # suspicious and we continue checking. + if {[string first \$ $str] == -1 && [string first \[ $str] == -1 && \ + [string index $str end] ne "\]" && \ + [string index $str end] ne "\""} { + return 1 + } + + set result 1 + set len [string length $str] + set escape 0 + set notype 0 + set types {} + set braces 0 + for {set i 0} {$i < $len} {incr i} { + set c [string index $str $i] + if {$c eq "\\"} { + set escape [expr {!$escape}] + set notype 1 + } elseif {!$escape} { + if {$c eq "\$"} { + incr i + lappend types [parseVar $str $len $index i knownVars] + set result 0 + } elseif {$c eq "\["} { + set si $i + for {} {$i < $len} {incr i} { + # FIXA: error => complete + if {[info complete [string range $str $si $i]]} { + break + } + } + if {$i == $len} { + decho "Internal error: Did not find close bracket in parseSubst.\ + Line [calcLineNo $index]" + } + incr si + incr i -1 + lappend types [parseBody [string range $str $si $i] \ + [expr {$index + $si}] knownVars 1] + incr i + set result 0 + } else { + set notype 1 + if {$c eq "\]" && $i == ($len - 1)} { + # Note unescaped bracket at end of word since it's + # likely to mean it should not be there. + errorMsg N "Unescaped end bracket" [expr {$index + $i}] + } elseif {$c eq "\"" && $i == ($len - 1)} { + # Note unescaped quote at end of word since it's + # likely to mean it should not be there. + errorMsg N "Unescaped quote" [expr {$index + $i}] + } elseif {$c eq "\{"} { + incr braces + # Unescaped brace in a word is suspicious + #errorMsg N "Unescaped brace" [expr {$index + $i}] + } elseif {$c eq "\}"} { + incr braces -1 + # Unescaped brace in a word is suspicious + if {$braces < 0} { + errorMsg N "Unescaped close brace" [expr {$index + $i}] + } + } + } + } else { + set escape 0 + set notype 1 + } + } + if {!$notype && [llength $types] == 1} { + set type [lindex $types 0] + } + return $result +} + +# Parse an expression +proc parseExpr {str index knownVarsName} { + upvar $knownVarsName knownVars + + # Allow a plugin to have a look at the expression before substitution + if {$::Nagelfar(pluginEarlyExpr)} { + pluginHandleEarlyExpr str knownVars $index + } + + # First do a quick check for $ or [ + if {[string first "\$" $str] == -1 && [string first "\[" $str] == -1} { + set exp $str + } else { + # This is similar to parseSubst, just that it also check for braces + set exp "" + set result 1 + set len [string length $str] + set escape 0 + set brace 0 + for {set i 0} {$i < $len} {incr i} { + set c [string index $str $i] + if {$c eq "\\"} { + set escape [expr {!$escape}] + } elseif {!$escape} { + if {$c eq "\{"} { + incr brace + } elseif {$c eq "\}"} { + if {$brace > 0} { + incr brace -1 + } + } elseif {$brace == 0} { + if {$c eq "\$"} { + incr i + parseVar $str $len $index i knownVars + append exp {${_____}} + continue + } elseif {$c eq "\["} { + set si $i + for {} {$i < $len} {incr i} { + if {[info complete [string range $str $si $i]]} { + break + } + } + if {$i == $len} { + errorMsg E "Missing close bracket at end of expression" $index + } + incr si + incr i -1 + # Warn if the called command is expr + set body [string range $str $si $i] + if {[string match "expr*" $body]} { + errorMsg N "Expr called in expression" \ + [expr {$index + $si}] + } + parseBody $body [expr {$index + $si}] knownVars 1 + incr i + append exp {${_____}} + continue + } + } + } else { + set escape 0 + } + append exp $c + } + } + + # Allow a plugin to have a look at the expression after substitution + if {$::Nagelfar(pluginLateExpr)} { + pluginHandleLateExpr exp knownVars $index + } + + # The above have replaced any variable substitution or command + # substitution in the expression by "${_____}" + set _____ 1 + + # This uses [expr] to do the checking which means that the checking + # can't recognise anything that differs from the Tcl version Nagelfar + # is run with. For example, the new operators in 8.4 "eq" and "ne" + # will be accepted even if the database was generated using an older + # Tcl version. A small problem and hard to fix, so I'm ignoring it. + + if {[catch [list expr $exp] msg]} { + regsub {syntax error in expression.*:\s+} $msg {} msg + # Divide by zero can happen due to the substitutions above + # but should normally not be caused by a syntax error + if {[string match "*divide by zero*" $msg]} return + # Another messages that means similar things + if {[string match "*square root of negative argument*" $msg]} return + if {[string match "*domain error: argument not in valid range*" $msg]} return + + # Invalid command name, look it up... + if {[regexp {invalid command name "(.*)"} $msg -> cmdName]} { + # FIXA: checking number of arguments to user defined functions? + # It would need manual parsing of some kind though + lookForCommand $cmdName [currentNamespace] $index + return + } + + errorMsg E "Bad expression: $msg" $index + } +} + +# This is to detect bad comments in constant lists. +# This will cause messages if there are comments in blocks +# that are not recognised as code. +proc checkForComment {word index} { + # Check for "#" + set si 0 + while {[set si [string first \# $word $si]] >= 0} { + # Is it first in a line? + if {[string index $word [expr {$si - 1}]] eq "\n"} { + errorMsg N "Suspicious \# char. Possibly a bad comment." \ + [expr {$index + $si}] + break + } + incr si + } +} + +# List version of checkForComment +proc checkForCommentL {words wordstatus indices} { + foreach word $words ws $wordstatus i $indices { + if {$ws & 2} { # Braced + checkForComment $word $i + } + } +} + +# A "macro" for checkCommand/parseStatement to print common error message +# It should not be called from anywhere else. +proc WA {{debug {}}} { + upvar 1 "cmd" cmd "index" index "argc" argc "argv" argv "indices" indices + upvar 1 "expandWords" expandWords + # Suppress message if expansions are present. We cannot know. + if {[llength $expandWords] > 0} { + return + } + errorMsg E "Wrong number of arguments ($argc) to \"$cmd\"$debug" $index 1 + + set t 1 + set line [calcLineNo $index] + foreach ix $indices { + set aline [calcLineNo $ix] + if {$aline != $line} { + contMsg "Argument $t at line $aline" + } + incr t + } +} + +# Take a syntax token and extract all parts +proc SplitToken {token tokName tokCountName typeName modName lenName fromName} { + upvar 1 $tokName tok $tokCountName tokCount $typeName type $modName mod \ + $lenName len $fromName from + set mod "" + set tokCount "" + set type "" + set tok _baad_ + set len 1 + set from "" + + if {[regexp {^(\w+)\((.*)\)$} $token -> tokL type]} { + # Type in parenthesis + } elseif {[regexp {^(\w+)\((.*)\)(\W.*)$} $token -> tokL type mod]} { + # Type in parenthesis, with modifier + } elseif {[regexp {^(\w+?)(\d*)(\W.*)?$} $token -> tokL tokCount mod]} { + # Normal format + } else { + #echo "Unsupported token '$token'" + return + } + # Look for the "=xx" part of a modifier + if {[regexp {^=(.+?)(\W*)$} $mod -> m1 m2]} { + set from $m1 + set mod $m2 + } + + set tok $tokL + # Some tokens eat multiple arguments + switch $tokL { + dp - dm - dmp { set len 3 } + dk - p - cv { set len 2 } + } +} + +# Some heuristics when non-braced non constant code is found +proc checkNonConstantCode {cmd arg tok type index} { + # Special case: [list ...] + if {[string match {\[list*} $arg]} { + # FIXA: Check the code + #echo "(List code)" + return + } + # Special case: single variable + if {[regexp {^\$[\w:]+$} $arg]} { + return + } + + # A specific type called "script" annotates a command that is known + # to build valid code. E.g. mymethod in Snit. + if {$type eq "script"} { + return + } + + if {$tok eq "c" || $tok eq "cv"} { + # FIXA: Handle other common methods to construct code? + + errorMsg N "No braces around code in $cmd statement." $index + } +} + +# Check a command that have a syntax defined in the database +# 'firsti' says at which index in argv et.al. the arguments begin. +# Returns the return type of the command +# This is a helper for parseStatement, it should not be called from +# anywhere but checkCommand/parseStatement +proc checkCommand {cmd index argv wordstatus wordtype indices \ + expandWords {firsti 0}} { + upvar 1 "constantsDontCheck" constantsDontCheck "knownVars" knownVars + + set argc [llength $argv] + set syn $::syntax($cmd) + set type "" + if {[info exists ::return($cmd)]} { + set type $::return($cmd) + #puts T:$cmd:$type + } + #puts "Checking $cmd ([lindex $argv]) against syntax $syn" + + # Check if the syntax definition has multiple entries + # Extract the valid one and continue as normal below + if {[string index [lindex $syn 0] end] == ":"} { + set na [expr {$argc - $firsti}] + set newsyn {} + set state search + foreach tok $syn { + if {$state == "search"} { + if {$tok == ":" || $tok == "${na}:"} { + set state copy + } + } elseif {$state == "copy"} { + if {[string index $tok end] == ":"} { + break + } + lappend newsyn $tok + } + } + if {[llength $newsyn] == 0} { + echo "Can't parse syntax definition for \"$cmd\": \"$syn\"" + return $type + } + set syn $newsyn + } + + # An integer token directly specifies number of arguments + if {[string is integer -strict $syn]} { + if {($argc - $firsti) != $syn} { + WA + } + checkForCommentL $argv $wordstatus $indices + return $type + } elseif {[lindex $syn 0] eq "r"} { + # A range of number of arguments + if {($argc - $firsti) < [lindex $syn 1]} { + WA + } elseif {[llength $syn] >= 3 && ($argc - $firsti) > [lindex $syn 2]} { + WA + } + checkForCommentL $argv $wordstatus $indices + return $type + } + + # Calculate the minimum number of arguments needed by non-optional + # tokens. If this is the same number as the actual arguments, we + # know that no optional tokens may consume anything. + # This prevents e.g. options checking on arguments that cannot be + # options due to their placement. + + if {![info exists ::cacheMinArgs($syn)]} { + set minargs 0 + set minargsend 0 + set optSeen 0 + set i 0 + set last [llength $syn] + foreach token $syn { + SplitToken $token _ _ _ mod tokLen _ + incr i + + if {$mod eq ""} { + # Count mandatory args + incr minargs $tokLen + if {$optSeen} { + incr minargsend $tokLen + } + } else { + # Note an optional, start counting end args + set minargsend 0 + set optSeen 1 + } + } + # Number of mandatory args at end + set ::cacheEndArgs($syn) $minargsend + # Number of mandatory args + set ::cacheMinArgs($syn) $minargs + } + set anyOptional [expr {($argc - $firsti) > $::cacheMinArgs($syn)}] + # Points at last optional + 1. I.e. an exclusive end-of-range + # In other words it points to the first of final mandatory args. + set lastOptional [expr {$argc - $::cacheEndArgs($syn)}] + + # Treat syn as a stack. That way a token can replace itself without + # increasing i and thus hand over checking to another token. + + set i $firsti + while {[llength $syn] > 0} { + # Pop first token from stack + set token [lindex $syn 0] + set syn [lrange $syn 1 end] + + # Look for multi token. + # A multi token is separated by & and always has a modifier. + if {[string match "*&*" $token]} { + set mod [string index $token end] + set newToks [split [string range $token 0 end-1] "&"] + if {$mod ni {* ?}} { + echo "Modifier \"$mod\" is not supported for \"$syn\" in\ + syntax for \"$cmd\"." + } + set room [expr {$lastOptional - $i}] + if {!$anyOptional || $room < [llength $newToks]} continue + # Feed back tokens to the stack + if {$mod eq "*"} { + # Include the multi-token if it repeats + set syn [linsert $syn 0 {*}$newToks $token] + } else { + set syn [linsert $syn 0 {*}$newToks] + } + continue + } + + SplitToken $token tok tokCount _ mod tokLen tokFrom + # Is it optional and there can't be any optional? + if {$mod ne "" && !$anyOptional} { + continue + } + # Basic checks for modifiers + switch -- $mod { + "" { # No modifier, and out of arguments, is an error + if {$i >= $argc} { + set i -1 + break + } + } + "*" { # No more arguments is ok. + if {$i >= $argc} { + set i $argc + break + } + # Supported by token? + if {$tok ni {x xComm div nl l v n o p}} { + echo "Modifier \"$mod\" is not supported for \"$tok\" in\ + syntax for \"$cmd\"." + } + } + "." { # No more arguments is ok. + if {$i >= $argc} { + set i $argc + break + } + # Supported by all tokens since the above check is all needed + } + "?" { # No more optional arguments is ok. + if {$i >= $lastOptional} { + continue + } + # Supported by all tokens since the above check is all needed + } + default { + echo "Unsupported token \"$token\" in syntax for \"$cmd\"" + } + } + + # Common init + # ei is an exclusive end-of-range for indexes covered by this token + set ei [expr {$i + 1}] + if {$mod eq "*"} { + set ei $lastOptional + } + + # Just skip the rest if expansion is encountered + if {[llength $expandWords] > 0 && $i >= [lindex $expandWords 0]} { + # Special token "X" means it should eat an expanded word. + set skip 1 + if {$i == [lindex $expandWords 0]} { + if {$tok eq "X"} { + set expandWords [lrange $expandWords 1 end] + incr i + continue + } + if {$tok in "o p"} { + # Fall down to option parsing + set skip 0 + } + } + if {$skip} { + #errorMsg N "Skipping $i due to expand" [lindex $indices $i] + set i $argc + break + } + } + + # Main token interpretation + switch -- $tok { + x - X - xComm { + # X is a special token to eat an expanded word. Handled above. + # xComm is a special token used internally to handle if 0 as + # a comment. xComm will not be investigated for inline comments + + set li [expr {$ei - 1}] + if {$tok != "xComm"} { + checkForCommentL [lrange $argv $i $li] \ + [lrange $wordstatus $i $li] \ + [lrange $indices $i $li] + } + set i $ei + } + div { # Define implicit variable for this namespace + set currNs [currentNamespace] + while {$i < $ei} { + set var [lindex $argv $i] + lappend ::implicitVarNs($currNs) $var + lappend constantsDontCheck $i + incr i + } + } + di { # Define inheritance + # Superclass + set superclass [lindex $argv $i] + set superObjCmd _obj,[namespace tail $superclass] + set objcmd [currentObject] + set copymap [list $objcmd $superObjCmd] + #puts "DI: '$superObjCmd' to '$objcmd' map '$copymap'" + set ::superclass($objcmd) [list $superclass $superObjCmd] + CopyCmdInDatabase $superObjCmd $objcmd $copymap + incr i + } + dc - do { # Define with copy / define object + # dc defines a command that is a copy. Typically used for an + # instance which is a copy of the class's object command. + # do defines both a command to instantiate objects and a + # corresponding object command + #decho "$tok $tokCount $mod" + if {([lindex $wordstatus $i] & 1) == 0} { # Non constant + errorMsg N "Non constant definition \"[lindex $argv $i]\".\ + Skipping." [lindex $indices $i] 1 + } else { + set copyFrom $tokFrom + set name [lindex $argv $i] + #decho "Defining '$name', from '$copyFrom'" + if {$name eq "%AUTO%"} { + # No defition should be made + } else { + if {[string match "::*" $name]} { + set name [string range $name 2 end] + } + if {$tok eq "do"} { # Define object + set objname _obj,[namespace tail $name] + #echo "Defining object $name" + setCurrentObject $objname $name + + # Special case when defining an object in tcloo + # Add an alias to make "my" an object + if {[string match oo::* $cmd]} { + # The construct of this should match how a + # virtual namespace context is named. + set ::knownAliases(${cmd}::${name}::my) $objname + } + + if {![info exists ::syntax($objname)]} { + set ::syntax($objname) "s x*" + } + if {$copyFrom ne ""} { + set copymap [list _obj,$copyFrom $objname] + CopyCmdInDatabase $copyFrom $name $copymap + CopyCmdInDatabase $copyFrom $objname $copymap + } else { + lappend ::knownCommands $objname + } + } else { + if {$copyFrom ne ""} { + CopyCmdInDatabase $copyFrom $name + } else { + lappend ::knownCommands $name + if {![info exists ::syntax($name)]} { + set ::syntax($name) "x*" + } + } + } + if {$tok eq "do" && ![info exists ::syntax($name)]} { + set ::syntax($name) "s x*" + } + } + } + incr i + } + dk - + dd - + dp - + dm - + dmp { # Define proc and/or method + if {$tok eq "dd"} { # One arg + if {$i > ($argc - 1)} { + break + } + set iplus2 [expr {$i + 0}] + } elseif {$tok eq "dk"} { # Two args + if {$i > ($argc - 2)} { + break + } + set iplus2 [expr {$i + 1}] + } else { + if {$i > ($argc - 3)} { + break + } + set iplus2 [expr {$i + 2}] + } + # Skip the proc if any part of it is not constant + # FIXA: Maybe accept substitutions as part of namespace? + foreach ws [lrange $wordstatus $i $iplus2] { + if {($ws & 1) == 0} { + errorMsg N "Non constant argument to proc \"[lindex $argv $i]\".\ + Skipping." $index + return + } + } + if {$::Nagelfar(gui)} {progressUpdate [calcLineNo $index]} + # Do not check proc/method name against variables + lappend constantsDontCheck $i + set isProc [expr {$tok eq "dp" || $tok eq "dmp"}] + set isMethod [expr {$tok eq "dm" || $tok eq "dmp"}] + if {$tok eq "dd"} { # One args + set procArgV [lrange $argv $i $iplus2] + set indicesV [lrange $indices $i $iplus2] + set constructorCmd "[currentObjectOrig] destructor" + set procArgV [linsert $procArgV 0 ::$constructorCmd {}] + set indicesV [linsert $indicesV 0 [lindex $indices $i] [lindex $indices $i]] + incr i 1 + } elseif {$tok eq "dk"} { # Two args + set procArgV [lrange $argv $i $iplus2] + set indicesV [lrange $indices $i $iplus2] + set constructorCmd "[currentObjectOrig] new" + # Suppress redefinition warnings + unset -nocomplain ::syntax($constructorCmd) + set procArgV [linsert $procArgV 0 ::$constructorCmd] + set indicesV [linsert $indicesV 0 [lindex $indices $i]] + #puts "DK: $procArgV" + incr i 2 + set synConstr [parseProc $procArgV $indicesV 0 0 $cmd] + set ::syntax($constructorCmd) $synConstr + # tcl::oo also knows the create constructor with a name + # for the new object: + set constructorCmd "[currentObjectOrig] create" + unset -nocomplain ::syntax($constructorCmd) + set objtype "_obj,[currentObjectOrig]" + if {[string is integer $synConstr]} { + set synConstr "dc=$objtype [string repeat "x " $synConstr]" + } else { + set synConstr "dc=$objtype $synConstr" + } + set ::syntax($constructorCmd) $synConstr + } else { + set procArgV [lrange $argv $i $iplus2] + set indicesV [lrange $indices $i $iplus2] + incr i 3 + parseProc $procArgV $indicesV \ + $isProc $isMethod $cmd + } + } + E - + e { # An expression + if {([lindex $wordstatus $i] & 1) == 0} { # Non constant + if {$tok == "E"} { + errorMsg W "No braces around expression in\ + $cmd statement." [lindex $indices $i] + } elseif {$::Prefs(warnBraceExpr)} { + # Allow pure command substitution if warnBraceExpr == 1 + if {$::Prefs(warnBraceExpr) == 2 || \ + [string index [lindex $argv $i] 0] != "\[" || \ + [string index [lindex $argv $i] end] != "\]" } { + errorMsg W "No braces around expression in\ + $cmd statement." [lindex $indices $i] + } + } + } elseif {[lindex $wordstatus $i] & 2} { # Braced + # FIXA: This is not a good check in e.g. a catch. + #checkForComment [lindex $argv $i] [lindex $indices $i] + } + parseExpr [lindex $argv $i] [lindex $indices $i] knownVars + incr i + } + c - cg - cl - cn { # A code block + if {([lindex $wordstatus $i] & 1) == 0} { # Non constant + # No braces around non constant code. + checkNonConstantCode $cmd [lindex $argv $i] $tok \ + [lindex $wordtype $i] [lindex $indices $i] + } else { + set body [lindex $argv $i] + if {$tokCount ne ""} { + # The appended value couldn't be e.g. 'x' in case + # the surrounding code has a variable named x. + append body [string repeat " ___" $tokCount] + } + # Special fix to support bind's "+". + if {$tok eq "cg" && [string match "+*" $body] && \ + $cmd eq "bind"} { + set body [string range $body 1 end] + set ixAfter [expr {[lindex $indices $i] + 1}] + # Instrument after the + + instrument $ixAfter 1 $body + } elseif {$tok ne "cn"} { + # A virtual namespace should not be instrumented. + instrumentL $indices $argv $i + } + if {$tok eq "cg"} { + # Check in global context + pushNamespace {} + set dummyVars {} + parseBody $body [lindex $indices $i] dummyVars + popNamespace + } elseif {$tok eq "cn"} { + # Check in virtual namespace context + set vNs ${cmd}::[join [lrange $argv $firsti [expr {$i-1}]] ::] + # Avoid :::: if a full qualified name is used + set vNs [string map {:::: ::} $vNs] + #puts "cmd '$cmd' vNs '$vNs'" + pushNamespace $vNs + set dummyVars {} + parseBody $body [lindex $indices $i] dummyVars + popNamespace + } elseif {$tok eq "cl"} { + #puts "Checking '$body' in local context" + # Check in local context + if {![info exists locCtxVars]} { + set locCtxVars {} + } + addImplicitVariablesNs $cmd [lindex $indices $i] locCtxVars + parseBody $body [lindex $indices $i] locCtxVars + checkForUnusedVar locCtxVars [lindex $indices $i] + } else { + parseBody $body [lindex $indices $i] knownVars + } + } + incr i + } + cv { # A code block with a variable definition and local context + # Needs two args + if {$i > ($argc - 2)} { + break + } + if {![info exists locCtxVars]} { + set locCtxVars {} + } + if {([lindex $wordstatus $i] & 1) != 0} { + # Constant var list, parse it to get all vars + parseArgs [lindex $argv $i] [lindex $indices $i] "" \ + locCtxVars + } else { + # Non constant var list, what to do? FIXA + } + addImplicitVariablesNs $cmd [lindex $indices $i] locCtxVars + # Handle Code part + incr i + if {([lindex $wordstatus $i] & 1) == 0} { # Non constant + # No braces around non constant code. + checkNonConstantCode $cmd [lindex $argv $i] $tok \ + [lindex $wordtype $i] [lindex $indices $i] + } else { + set body [lindex $argv $i] + if {$tokCount ne ""} { + append body [string repeat " x" $tokCount] + } + instrumentL $indices $argv $i + + # Check in local context + #puts "Cmd '$cmd' NS '[currentNamespace]'" + parseBody $body [lindex $indices $i] locCtxVars + checkForUnusedVar locCtxVars [lindex $indices $i] + } + incr i + } + s { # A subcommand + lappend constantsDontCheck $i + if {([lindex $wordstatus $i] & 1) == 0} { # Non constant + errorMsg N "Non static subcommand to \"$cmd\"" \ + [lindex $indices $i] + } else { + set arg [lindex $argv $i] + if {[info exists ::subCmd($cmd)]} { + if {[lsearch $::subCmd($cmd) $arg] == -1} { + set ix [lsearch -glob $::subCmd($cmd) $arg*] + if {$ix == -1} { + errorMsg E "Unknown subcommand \"$arg\" to \"$cmd\""\ + [lindex $indices $i] + } else { + # Check ambiguity. + set match [lsearch -all -inline -glob \ + $::subCmd($cmd) $arg*] + if {[llength $match] > 1} { + errorMsg E "Ambigous subcommand for\ + \"$cmd\", $arg ->\ + [join $match /]" \ + [lindex $indices $i] + } elseif {$::Prefs(warnShortSub)} { + # Report shortened subcmd? + errorMsg W "Shortened subcommand for\ + \"$cmd\", $arg ->\ + [lindex $match 0]" \ + [lindex $indices $i] + } + set arg [lindex $::subCmd($cmd) $ix] + } + } + } elseif {$::Nagelfar(dbpicky)} { + errorMsg N "DB: Missing subcommands for \"$cmd\"" 0 + } + # Are there any syntax definition for this subcommand? + set sub "$cmd $arg" + if {[info exists ::syntax($sub)]} { + set stype [checkCommand $sub $index $argv $wordstatus \ + $wordtype \ + $indices $expandWords [expr {$i + 1}]] + if {$stype != ""} { + set type $stype + } + set i $argc + break + } elseif {$::Nagelfar(dbpicky)} { + errorMsg N "DB: Missing syntax for subcommand $sub" 0 + } + } + incr i + } + nl - + l - + v - + n { # A call by name + set typeFromToken $tokFrom + set isArray unknown + if {$typeFromToken eq "array"} { + set isArray yes + } elseif {$typeFromToken eq "scalar"} { + set isArray known + } + while {$i < $ei} { + if {$tok eq "v"} { + # Check the variable + set var [lindex $argv $i] + # Allow a plugin to have a look at the variable read + if {$::Nagelfar(pluginVarRead)} { + pluginHandleVarRead var knownVars $index + } + setVarUsed knownVars $var + if {[string match ::* $var]} { + # Skip qualified names until we handle + # namespace better. FIXA + } elseif {[markVariable $var \ + [lindex $wordstatus $i] [lindex $wordtype $i] \ + 2 [lindex $indices $i] $isArray \ + knownVars vtype]} { + if {!$::Prefs(noVar)} { + errorMsg E "Unknown variable \"$var\""\ + [lindex $indices $i] 1 + } + } + } elseif {$tok eq "n"} { + markVariable [lindex $argv $i] \ + [lindex $wordstatus $i] [lindex $wordtype $i] 1 \ + [lindex $indices $i] $isArray knownVars "" + } elseif {$tok eq "nl"} { + set ws [lindex $wordstatus $i] + if {($ws & 1) == 0} { + errorMsg N "Non constant variable list." \ + [lindex $indices $i] + } else { + foreach varName [lindex $argv $i] { + markVariable $varName \ + $ws [lindex $wordtype $i] 1 \ + [lindex $indices $i] $isArray knownVars "" + } + } + } else { + # Mark it as just known. This does not trigger plugin + markVariable [lindex $argv $i] \ + [lindex $wordstatus $i] [lindex $wordtype $i] 0 \ + [lindex $indices $i] $isArray knownVars "" + + # not strictly speaking used but info exists etc + # may cause a lot of false-positive without this + set var [lindex $argv $i] + set varBase [lindex [split [lindex $argv $i] "("] 0] + setVarUsed knownVars $varBase + if {$var ne $varBase} { + setVarUsed knownVars $var + } + } + + lappend constantsDontCheck $i + incr i + } + } + o { + set max [expr {$ei - $i}] + set oSyn [checkOptions $cmd $argv $wordstatus $indices $wordtype \ + $i $max 0] + set used [llength $oSyn] + if {$used == 0 && ($mod == "" || $mod == ".")} { + errorMsg E "Expected an option as argument $i to \"$cmd\"" \ + [lindex $indices $i] + return $type + } + + if {[lsearch -not $oSyn "x"] >= 0} { + # Feed the syntax back into the check loop + set syn [concat $oSyn $syn] + } else { + incr i $used + } + } + p { + set max [expr {$ei - $i}] + if {$max < 2} { + set max 2 + } + set oSyn [checkOptions $cmd $argv $wordstatus $indices $wordtype \ + $i $max 1] + set used [llength $oSyn] + if {$used == 0 && ($mod == "" || $mod == ".")} { + errorMsg E "Expected an option as argument $i to \"$cmd\"" \ + [lindex $indices $i] + return $type + } + if {[lsearch -not $oSyn "x"] >= 0} { + # Feed the syntax back into the check loop + set syn [concat $oSyn $syn] + } else { + incr i $used + } + } + re { + # Check only constant + if {([lindex $wordstatus $i] & 1) != 0} { + set re [lindex $argv $i] + if {[catch [list regexp -- $re "test"] msg]} { + errorMsg E "Bad regexp: $msg" $index + } + } + incr i + } + default { + echo "Unsupported token \"$token\" in syntax for \"$cmd\"" + } + } ;# End switch Main token interpretation + } ; # End while + # Have we used up all arguments? + if {$i != $argc} { + WA + } + return $type +} + +# Central function to handle known variable names. +# If check is 2, check if it is known, return 1 if unknown +# If check is 1, mark the variable as known and set +# If check is 1n, mark the variable as known and set, but do not trigger plugin +# If check is 0, mark the variable as known +proc markVariable {var ws wordtype check index isArray knownVarsName typeName} { + upvar $knownVarsName knownVars + if {$typeName ne ""} { + upvar $typeName type + } else { + set type "" + } + if {$check eq "1n"} { + set check 1 + } elseif {$check == 1} { + # Allow a plugin to have a look at the variable written + if {$::Nagelfar(pluginVarWrite)} { + pluginHandleVarWrite var knownVars $index + } + } + + set varBase $var + set varArray 0 + set varIndex "" + set varBaseWs $ws + set varIndexWs $ws + + # is it an array? + set i [string first "(" $var] + if {$i != -1} { + incr i -1 + set varBase [string range $var 0 $i] + incr i 2 + set varIndex [string range $var $i end-1] + # Check if the base is free from substitutions + if {($varBaseWs & 1) == 0 && [regexp {^(::)?(\w+(::)?)+$} $varBase]} { + set varBaseWs 1 + } + set varArray 1 + } + + # If the base contains substitutions it can't be checked. + if {($varBaseWs & 1) == 0} { + # Experimental foreach check FIXA + if {[string match {$*} $var]} { + set name [string range $var 1 end] + if {[info exists ::foreachVar($name)]} { + # Mark them as known instead + foreach name $::foreachVar($name) { + markVariable $name 1 "" $check $index known knownVars "" + } + #return 1 + } + } + if {$wordtype ne "varName"} { + # A common namespace idiom is ${x}::y + if {[regexp {^\${\w+}(::\w+)+} $var]} { + # Do anything? + } else { + errorMsg N "Suspicious variable name \"$var\"" $index + } + } + return 0 + } + + # Check for scalar/array mismatch + if {$check != 2 && [dict exists $knownVars $varBase] && + [dict get $knownVars $varBase array] ne ""} { + set varReallyArray [expr {$varArray || $isArray eq "yes"}] + if {$varReallyArray != [dict get $knownVars $varBase array]} { + if {$varReallyArray} { + errorMsg E "Is array, was scalar" $index + } else { + if {$isArray ne "unknown"} { + errorMsg E "Is scalar, was array" $index + } + } + } + } + + if {$check == 2} { + # This is a check, so "type" is an out, not an inout. + # Ignore any incoming value. + set type "" + if {![dict exists $knownVars $varBase]} { + return 1 + } + if {[dict exists $knownVars $var] && + [dict get $knownVars $var "type"] ne ""} { + set type [dict get $knownVars $var "type"] + } else { + set type [dict get $knownVars $varBase "type"] + } + return 0 + } else { + if {![dict exists $knownVars $varBase]} { + knownVar knownVars $varBase + if {[currentProc] ne ""} { + dict set knownVars $varBase local 1 + } else { + dict set knownVars $varBase namespace [currentNamespace] + } + if {$check == 1} { + if {$isArray eq "known"} { + dict set knownVars $varBase array $varArray + } elseif {$isArray eq "yes"} { + dict set knownVars $varBase array 1 + } + } + if {$varArray || $isArray eq "yes"} { + dict set knownVars $varBase array 1 + } + } + # A non-type cannot override a known type + if {$type ne ""} { + if {$varArray} { + set oldType [dict get $knownVars $varBase "type"] + if {$oldType ne "" && $type ne $oldType} { + # Inconsistent types. Mark base as unknown. + dict set knownVars $varBase "type" _unknown + } else { + dict set knownVars $varBase "type" $type + } + } else { + # Warn if changed in a scalar?? FIXA + dict set knownVars $varBase "type" $type + } + } + if {$check == 1} { + dict set knownVars $varBase set 1 + } + # If the array index is constant, mark the whole name + if {$varArray && ($varIndexWs & 1)} { + if {![dict exists $knownVars $var]} { + knownVar knownVars $var + if {[dict get $knownVars $varBase local]} { + dict set knownVars $var local 1 + } + dict set knownVars $var array 0 + } + if {$type ne ""} { + dict set knownVars $var "type" $type + } + if {$check == 1} { + dict set knownVars $var set 1 + setVarUsed knownVars $var + } + } + } +} + +# Just for setting a known variable's type +proc setVariableType {var type index knownVarsName} { + upvar $knownVarsName knownVars + # TODO parse variable for array etc? + set varBase $var + if {![dict exists $knownVars $varBase]} { + errorMsg E "Unknown variable \"$varBase\"" $index 1 + return + } + dict set knownVars $varBase "type" $type +} + +# Check if a name in knownVars has a used count of <= 1 +proc checkForUnusedVar {knownVarsName {idx 0}} { + upvar $knownVarsName knownVars + + if {$::Nagelfar(firstpass)} { + return + } + if {$::Prefs(noVar) || !$::Prefs(warnUnusedVar)} { + return + } + + dict for {var info} $knownVars { + # ignore qualified names and everything starting with "_" + if {$var eq "" || [string first "::" $var] >= 0 || [string index $var 0] eq "_"} { + continue + } + if {$var in $::Prefs(warnUnusedVarFilter)} { + continue + } + if {![dict exists $info used]} { + continue + } + set val [dict get $info used] + if {$val == 0 || ($val == -1 && ![dict get $info set])} { + errorMsg W "Variable \"$var\" is never read" $idx + } + } +} + +proc setVarUsed {knownVarsName var {kind 1}} { + upvar $knownVarsName knownVars + if {[dict exists $knownVars $var used]} { + dict set knownVars $var used $kind + } +} + +# This is called when an unknown command is encountered. +# If not found it is stored to be checked last. +# Returns a list with a partial command where the first element +# is the resolved name with qualifier. +proc lookForCommand {cmd ns index} { + # Get both the namespace and global possibility + set cmds {} + if {[string match "::*" $cmd]} { + # Fully qualified, so only one possible + set cmds [list [string range $cmd 2 end]] + } elseif {$ns ne "__unknown__" } { + # Look through all levels of namespaces + set nsSearchPath {} + set nsPrefix $ns + while {$nsPrefix ne ""} { + lappend nsSearchPath $nsPrefix + if {[info exists ::namespacePath($nsPrefix)]} { + lappend nsSearchPath {*}$::namespacePath($nsPrefix) + } + set nsPrefix [namespace qualifiers $nsPrefix] + } + foreach nsPrefix $nsSearchPath { + set cmd1 "${nsPrefix}::$cmd" + if {[string match "::*" $cmd1]} { + set cmd1 [string range $cmd1 2 end] + } + lappend cmds $cmd1 + } + lappend cmds $cmd + } else { + set cmds [list $cmd] + } + + #puts "MOO cmd '$cmd' ns '$ns' '$cmds'" + foreach cmdCandidate $cmds { + if {[info exists ::knownAliases($cmdCandidate)]} { + return $::knownAliases($cmdCandidate) + } + if {[info exists ::syntax($cmdCandidate)]} { + return [list $cmdCandidate] + } + if {[lsearch -exact $::knownCommands $cmdCandidate] >= 0} { + return [list $cmdCandidate] + } + } + if {[lsearch -exact $::knownCommands $cmd] >= 0} { + return [list $cmd] + } + + if {$index >= 0 && !$::Nagelfar(firstpass)} { + lappend ::unknownCommands [list $cmd $cmds $index] + } + return "" +} + +# Check for commands with special syntax that cannot be handled be checkCommand +# Returns 1 if command has been handled, 2 if fully done with command +# This is a helper for parseStatement, it should not be called from +# anywhere but parseStatement +proc checkSpecial {cmd index argv wordstatus wordtype indices expandWords} { + upvar 1 "constantsDontCheck" constantsDontCheck "knownVars" knownVars + upvar 1 "noConstantCheck" noConstantCheck "type" type + + set argc [llength $argv] + + if {[string match ".*" $cmd]} { + # FIXA, check code in any -command. + # Even widget commands should be checked. + # Maybe in checkOptions ? + return 2 + } + # FIXA: handle {*} better? + # Most of the handlers below cannot cope with expansion. + # FIXA: Maybe e.g. "set" should complain since expansion does not make sense? + if {[llength $expandWords] > 0} { + if {$cmd ni {foreach}} { + return 0 + } + } + + switch $cmd { + global { # Special check of "global" command + foreach var $argv ws $wordstatus { + if {$ws & 1} { + knownVar knownVars $var + setVarUsed knownVars $var -1 + } else { + errorMsg N "Non constant argument to $cmd: $var" $index + } + } + set noConstantCheck 1 + } + variable { # Special check of "variable" command + # Look for a defined syntax in this namespace + set currNs [currentNamespace] + set rescmd [lookForCommand $cmd $currNs $index] + if {[llength $rescmd] > 0 && \ + [info exists ::syntax([lindex $rescmd 0])]} { + # If it resides outside a procedure, it most likely + # defines implicit variables. Fall back to syntax def. + # This might not cover all cases, but is good enough for now. + if {[currentProc] eq ""} { + return 0 + } + } + set i 0 + foreach {var val} $argv {ws1 ws2} $wordstatus { + set ns [currentNamespace] + if {[regexp {^(.*)::([^:]+)$} $var -> root var]} { + set ns $root + if {[string match "::*" $ns]} { + set ns [string range $ns 2 end] + } + } + if {$ns ne "__unknown__"} { + if {($ws1 & 1) || [string is wordchar $var]} { + knownVar knownVars $var + dict set knownVars $var namespace $ns + if {$i < $argc - 1} { + dict set knownVars $var set 1 + dict set knownVars $var used 1 + dict set knownVars $var array 0 + # FIXA: What if it is an array element? + # Should the array be marked? + } else { + setVarUsed knownVars $var -1 + } + lappend constantsDontCheck $i + } else { + errorMsg N "Non constant argument to $cmd: $var" \ + $index + } + } + incr i 2 + } + } + upvar { # Special check of "upvar" command + if {$argc < 2} { + WA + return 2 + } + set level [lindex $argv 0] + set oddA [expr {$argc % 2 == 1}] + set hasLevel 0 + if {[lindex $wordstatus 0] & 1} { + # Is it a level ? + if {[regexp {^[\\\#0-9]} $level]} { + if {!$oddA} { + WA + return 2 + } + set hasLevel 1 + } else { + if {$oddA} { + WA + return 2 + } + set level 1 + } + } else { + # Assume it is not a level unless odd number of args. + if {$oddA} { + # Warn here? FIXA + errorMsg N "Non constant level to $cmd: \"$level\"" $index + set hasLevel 1 + set level "" + } else { + set level 1 + } + } + if {$hasLevel} { + set tmp [lrange $argv 1 end] + set tmpWS [lrange $wordstatus 1 end] + set tmpT [lrange $wordtype 1 end] + set i 2 + } else { + set tmp $argv + set tmpWS $wordstatus + set tmpT $wordtype + set i 1 + } + + foreach {other var} $tmp {wsO wsV} $tmpWS {tO tV} $tmpT { + if {($wsV & 1) == 0} { + # The variable name contains substitutions + if {$tV eq "varName"} { + # It is OK + } else { + errorMsg N "Suspicious upvar variable \"$var\"" $index + } + } else { + knownVar knownVars $var + setVarUsed knownVars $var -1 + lappend constantsDontCheck $i + if {$other eq $var} { # Allow "upvar xx xx" construct + lappend constantsDontCheck [expr {$i - 1}] + } + if {($wsO & 1) == 0} { + # Is the other name a simple var subst? + if {[regexp {^\$([\w()]+)$} $other -> other] || \ + [regexp {^\${([^{}]*)}$} $other -> other]} { + if {[dict exists $knownVars $other]} { + if {$level == 1} { + dict set knownVars $other upvar $var + } elseif {$level eq "#0"} { + # FIXA: level #0 for global + dict set knownVars $other upvar $var + dict set knownVars $var set 1 ;# FIXA? + } + } + } + } + } + incr i 2 + } + } + set { # Special check of "set" command + # Set gets a different syntax string depending on the + # number of arguments. + set wtype "" + if {$argc == 1} { + # Check the variable + set var [lindex $argv 0] + # Allow a plugin to have a look at the variable read + if {$::Nagelfar(pluginVarRead)} { + pluginHandleVarRead var knownVars $index + } + setVarUsed knownVars $var + if {[string match ::* $var]} { + # Skip qualified names until we handle + # namespace better. FIXA + } elseif {[markVariable $var \ + [lindex $wordstatus 0] [lindex $wordtype 0] \ + 2 [lindex $indices 0] known knownVars wtype]} { + if {!$::Prefs(noVar)} { + errorMsg E "Unknown variable \"$var\""\ + [lindex $indices 0] 1 + } + } + } elseif {$argc == 2} { + set wtype [lindex $wordtype 1] + markVariable [lindex $argv 0] \ + [lindex $wordstatus 0] [lindex $wordtype 0] \ + 1 [lindex $indices 0] known \ + knownVars wtype + } else { + WA + } + lappend constantsDontCheck 0 + + set type $wtype + } + foreach - lmap { # Special check of "foreach" and "lmap" commands + # Check that we are in at least 8.6 for lmap + if {$cmd eq "lmap" && ![info exists ::syntax(lmap)]} { + return 0 + } + # Handle expansion. + # As long as the last arg is stable the body can be checked. + set onlybody 0 + if {[llength $expandWords] > 0} { + if {([lindex $wordstatus end] & 8) != 0} { + return 0 + } + set onlybody 1 + } + set varsAdded {} + + if {!$onlybody} { + if {$argc < 3 || ($argc % 2) == 0} { + WA + return 2 + } + for {set i 0} {$i < $argc - 1} {incr i 2} { + if {[lindex $wordstatus $i] == 0} { + errorMsg W "Non constant variable list to foreach\ + statement." [lindex $indices $i] + # FIXA, maybe abort here? + } + lappend constantsDontCheck $i + foreach var [lindex $argv $i] { + markVariable $var 1 "" 1 $index known knownVars "" + } + } + # FIXA: Experimental foreach check... + # A special case for looping over constant lists + foreach {varList valList} [lrange $argv 0 end-1] \ + {varWS valWS} [lrange $wordstatus 0 end-1] { + if {($varWS & 1) && ($valWS & 1)} { + set fVars {} + foreach fVar $varList { + set ::foreachVar($fVar) {} + lappend fVars apaV($fVar) + lappend varsAdded $fVar + } + ##nagelfar ignore Non constant variable list to foreach + foreach $fVars $valList { + foreach fVar $varList { + ##nagelfar variable apaV + lappend ::foreachVar($fVar) $apaV($fVar) + } + } + } + } + } + + if {([lindex $wordstatus end] & 1) == 0} { + errorMsg W "No braces around body in foreach\ + statement." $index + } + instrumentL $indices $argv end + set type [parseBody [lindex $argv end] [lindex $indices end] \ + knownVars] + # Clean up + foreach fVar $varsAdded { + catch {unset ::foreachVar($fVar)} + } + } + if { # Special check of "if" command + if {$argc < 2} { + WA + return 2 + } + set old_ifsyntax $::syntax(if) + # Build a syntax string that fits this if statement + set state expr + set ifsyntax {} + foreach arg $argv ws $wordstatus index $indices { + switch -- $state { + skip { + # This will behave bad with "if 0 then then"... + lappend ifsyntax xComm + if {$arg ne "then"} { + set state else + } + continue + } + then { + set state body + if {$arg eq "then"} { + lappend ifsyntax x + continue + } + } + else { + if {$arg eq "elseif"} { + set state expr + lappend ifsyntax x + continue + } + set state lastbody + if {$arg eq "else"} { + lappend ifsyntax x + continue + } + if {$::Prefs(forceElse)} { + errorMsg E "Badly formed if statement" $index + contMsg "Found argument '[trimStr $arg]' where\ + else/elseif was expected." + return 2 + } + } + } + switch -- $state { + expr { + # Handle if 0 { ... } as a comment + if {[string is integer $arg] && $arg == 0} { + lappend ifsyntax x + set state skip + } else { + lappend ifsyntax e + set state then + } + } + lastbody { + lappend ifsyntax c + set state illegal + } + body { + lappend ifsyntax c + set state else + } + illegal { + errorMsg E "Badly formed if statement" $index + contMsg "Found argument '[trimStr $arg]' after\ + supposed last body." + return 2 + } + } + } + # State should be "else" if there was no else clause or + # "illegal" if there was one. + if {$state ne "else" && $state ne "illegal"} { + errorMsg E "Badly formed if statement" $index + contMsg "Missing one body." + return 2 + } elseif {$state eq "else"} { + # Mark the missing else for instrumenting + instrument [expr {$index + [string length $arg]}] 2 "" + } +# decho "if syntax \"$ifsyntax\"" + set ::syntax(if) $ifsyntax + checkCommand $cmd $index $argv $wordstatus $wordtype $indices \ + $expandWords + set ::syntax(if) $old_ifsyntax + } + try { # Special check of "try" command + # Check that we are in at least 8.6 + if {![info exists ::syntax(try)]} { + return 0 + } + if {$argc < 1} { + WA + return 2 + } + set old_trysyntax $::syntax(try) + # Build a syntax string that fits this try statement + set state body + set trysyntax {} + foreach arg $argv ws $wordstatus index $indices { + switch -- $state { + body { + lappend trysyntax c + set state handler + continue + } + finally { + lappend trysyntax c + set state illegal + continue + } + handler { + if {$arg eq "on" || $arg eq "trap"} { + set state code + lappend trysyntax x + continue + } + if {$arg eq "finally"} { + lappend trysyntax x + set state finally + continue + } + errorMsg E "Bad word in try statement, should be on, trap or finally." $index + return 2 + } + code { + lappend trysyntax x + set state varlist + continue + } + varlist { + lappend trysyntax nl + set state body + continue + } + illegal { + errorMsg E "Badly formed try statement" $index + contMsg "Found argument '[trimStr $arg]' after\ + supposed last body." + return 2 + } + } + } + # State should be "handler" or "illegal" + if {$state ne "handler" && $state ne "illegal"} { + errorMsg E "Badly formed try statement" $index + #contMsg "Missing one body." + return 2 + } + #decho "$argc try syntax \"$trysyntax\"" + set ::syntax(try) $trysyntax + checkCommand $cmd $index $argv $wordstatus $wordtype $indices \ + $expandWords + set ::syntax(try) $old_trysyntax + } + switch { # Special check of "switch" command + if {$argc < 2} { + WA + return 2 + } + # FIXA: As of 8.5.1, two args are not checked for options, + # does this imply anything + set i 0 + if {$argc > 2} { + set max [expr {$argc - 2}] + set oSyn [checkOptions $cmd $argv $wordstatus $indices $wordtype \ + 0 $max 0] + set i [llength $oSyn] + if {[lsearch -not $oSyn "x"] >= 0} { + # There is some special flag in there, probably a var + set old_swsyntax $::syntax(switch) + lappend oSyn xComm* + set ::syntax(switch) $oSyn + checkCommand $cmd $index $argv $wordstatus $wordtype \ + $indices $expandWords + set ::syntax(switch) $old_swsyntax + } + } + if {[lindex $wordstatus $i] & 1 == 1} { + # First argument to switch is constant, suspiscious + errorMsg N "String argument to switch is constant" \ + [lindex $indices $i] + } + incr i + set left [expr {$argc - $i}] + + if {$left == 1} { + # One block. Split it into a list. + # FIXA. Changing argv messes up the constant check. + + set arg [lindex $argv $i] + set ws [lindex $wordstatus $i] + set ix [lindex $indices $i] + + if {($ws & 1) == 1} { + set swargv [splitList $arg $ix swindices swwordst] + if {[llength $swargv] % 2 == 1} { + errorMsg E "Odd number of elements in last argument to\ + switch." $ix + return 2 + } + if {[llength $swargv] == 0} { + errorMsg W "Empty last argument to switch." $ix + return 2 + } + } else { + set swwordst {} + set swargv {} + set swindices {} + } + } elseif {$left % 2 == 1} { + WA + return 2 + } else { + set swargv [lrange $argv $i end] + set swwordst [lrange $wordstatus $i end] + set swindices [lrange $indices $i end] + } + set count [llength $swargv] + foreach {pat body} $swargv {ws1 ws2} $swwordst {i1 i2} $swindices { + incr count -2 + # A stand-alone hash as a pattern is suspicious + if {[string index $pat 0] eq "#" && $ws1 == 1} { + # Skip warning if body is braced + if {$ws2 != 3} { + errorMsg W "Switch pattern starting with #.\ + This could be a bad comment." $i1 + } + } + if {$body eq "-"} { + continue + } + if {($ws2 & 1) == 0} { + errorMsg W "No braces around code in switch\ + statement." $i2 + } + if {$pat eq "others" && $ws1 == 1 && $count == 0} { + # Bareword "others" when last can be a mistake since other + # languages use it as the "default" keyword. + errorMsg N "Switch pattern \"others\" could be a mistaken\ + \"default\"" $i1 + } + instrument $i2 1 $body + parseBody $body $i2 knownVars + } + } + expr { # Special check of "expr" command + # FIXA + # Take care of the standard case of a brace enclosed expr. + if {$argc == 1 && ([lindex $wordstatus 0] & 1)} { + parseExpr [lindex $argv 0] [lindex $indices 0] knownVars + } else { + if {$::Prefs(warnBraceExpr)} { + errorMsg W "Expr without braces" [lindex $indices 0] + } + } + } + eval { # Special check of "eval" command + # FIXA + set noConstantCheck 1 + } + interp { # Special check of "interp" command + if {$argc < 1} { + WA + return 2 + } + # Special handling of interp alias + if {([lindex $wordstatus 0] & 1) && "alias" eq [lindex $argv 0]} { + if {$argc < 3} { + WA + return 2 + } + # This should define a source in the current interpreter + # with a known name. + if {$argc >= 5 && \ + ([lindex $wordstatus 1] & 1) && \ + "" eq [lindex $argv 1] && \ + ([lindex $wordstatus 2] & 1)} { + set newAlias [lindex $argv 2] + set aliasCmd {} + for {set t 4} {$t < $argc} {incr t} { + if {[lindex $wordstatus 1] & 1} { + lappend aliasCmd [lindex $argv $t] + } else { + lappend aliasCmd {} + } + } + set ::knownAliases($newAlias) $aliasCmd + } + } + set type [checkCommand $cmd $index $argv $wordstatus \ + $wordtype $indices $expandWords] + set noConstantCheck 1 + } + package { # Special check of "package" command + # Take care of require to autoload package definition + if {$argc >= 2 && [lindex $argv 0] eq "require"} { + set nameI 1 + if {[string match "-*" [lindex $argv $nameI]]} { + incr nameI + } + if {$nameI < $argc} { + if {[lindex $wordstatus $nameI] & 1} { + set pName [lindex $argv $nameI] + lookForPackageDb $pName [lindex $indices $nameI] + } else { + errorMsg N "Non constant package require" \ + [lindex $indices $nameI] + } + } + } + set type [checkCommand $cmd $index $argv $wordstatus $wordtype \ + $indices $expandWords] + } + namespace { # Special check of "namespace" command + if {$argc < 1} { + WA + return 2 + } + # Special handling of namespace eval + if {([lindex $wordstatus 0] & 1) && \ + [string match "ev*" [lindex $argv 0]]} { + if {$argc < 3} { + WA + return 2 + } + set arg1const [expr {[lindex $wordstatus 1] & 1}] + set arg2const [expr {[lindex $wordstatus 2] & 1}] + # Look for unknown parts + if {[string is space [lindex $argv 2]]} { + # Empty body, do nothing + } elseif {$arg2const && $argc == 3} { + if {$arg1const} { + set ns [lindex $argv 1] + if {![string match "::*" $ns]} { + set root [currentNamespace] + if {$root ne "__unknown__"} { + set ns ${root}::$ns + } + } + } else { + set ns __unknown__ + } + + pushNamespace $ns + parseBody [lindex $argv 2] [lindex $indices 2] knownVars + popNamespace + } else { + errorMsg N "Only braced namespace evals are checked." \ + [lindex $indices 0] 1 + } + } elseif {([lindex $wordstatus 0] & 1) && \ + [string match "im*" [lindex $argv 0]]} { + # Handle namespace import + if {$argc < 2} { + # Import without args is not interesting + return 2 + } + set ns [currentNamespace] + if {[lindex $argv 1] eq "-force"} { + set t 2 + } else { + set t 1 + } + for {} {$t < [llength $argv]} {incr t} { + if {([lindex $wordstatus $t] & 1) == 0} { + # Non constant cannot be checked + continue + } + set candidate [lindex $argv $t] + set others [lookForCommand $candidate $ns -1] + set others [lrange $others 0 0] + if {[llength $others] == 0} { + # Fall back on trying glob matching + if {[string match "::*" $candidate]} { + set candidate [string range $candidate 2 end] + } + # If it is an import of * we make the assumption + # that only lower-case procs are imported, since we + # do not know the export list + if {[string match "*::\\*" $candidate]} { + set candidate [string range $candidate 0 end-1] + append candidate {[a-z]*} + } + set others [lsearch -all -inline -glob $::knownCommands $candidate] + } + foreach other $others { + set tail [namespace tail $other] + if {$ns eq ""} { + set me $tail + } else { + set me ${ns}::$tail + if {[string match "::*" $me]} { + set me [string range $me 2 end] + } + } + #puts "ME: $me : OTHER: $other" + # Copy the command info + if {[lsearch -exact $::knownCommands $me] < 0} { + lappend ::knownCommands $me + } + if {![info exists ::syntax($me)] && \ + [info exists ::syntax($other)]} { + set ::syntax($me) $::syntax($other) + } + } + } + set type [checkCommand $cmd $index $argv $wordstatus \ + $wordtype $indices $expandWords] + } elseif {([lindex $wordstatus 0] & 1) && \ + [string match "pa*" [lindex $argv 0]]} { + # Handle namespace path + if {$argc > 2} { + WA + return 2 + } + # Stupid simple search for obvious names + set targets [regexp -all -inline {[\w:]+} $argv] + set ns [currentNamespace] + foreach target $targets { + if {![string match "*::*" $target]} continue + #puts "Added '$target' to '$ns'" + lappend ::namespacePath($ns) $target + } + } else { + set type [checkCommand $cmd $index $argv $wordstatus \ + $wordtype $indices $expandWords] + } + } + next { # Special check of "next" command + # Figure out the superclass of the caller to be able to check + set currObj [currentObject] + if {[info exists ::superclass($currObj)]} { + foreach {superCmd superObj} $::superclass($currObj) break + set methodName [namespace tail [currentProc]] + #puts "next: super '$superObj' meth '$methodName'" + if {[string match "* new" $methodName]} { + # This is a constructor + set subCmd "$superCmd new" + } else { + set subCmd "$superObj $methodName" + } + if {[info exists ::syntax($subCmd)]} { + #puts "Syntax for '$subCmd' '$::syntax($subCmd)'" + set type [checkCommand $subCmd $index $argv $wordstatus \ + $wordtype $indices $expandWords] + } + } else { + errorMsg N "No superclass found for 'next'" $index + } + } + tailcall { # Special check of "tailcall" command + if {$argc < 1} { + WA + return 2 + } + set newStatement [join $argv] + set newIndex [lindex $indices 0] + set type [parseStatement $newStatement $newIndex knownVars] + set noConstantCheck 1 + } + uplevel { # Special check of "uplevel" command + # FIXA + set noConstantCheck 1 + } + default { + return 0 + } + } + return 1 +} + +# Parse one statement and check the syntax of the command +# Returns the return type of the statement +proc parseStatement {statement index knownVarsName} { + upvar $knownVarsName knownVars + + # Allow a plugin to have a look at the statement + if {$::Nagelfar(pluginStatementRaw)} { + pluginHandleStatementRaw statement knownVars $index + } + + set words [splitStatement $statement $index indices] + + # Allow a plugin to have a look at the statement words + if {$::Nagelfar(pluginStatementWords)} { + pluginHandleStatementWords words knownVars $index + } + + if {[llength $words] == 0} {return} + + addImplicitVariablesCmd [join $words] $index knownVars + + if {$::Nagelfar(firstpass)} { + set cmd [lindex $words 0] + if {$cmd eq "proc"} { + # OK + } elseif {$cmd eq "namespace" && \ + [lindex $words 1] eq "eval" && \ + [llength $words] == 4 && \ + ![regexp {[][$\\]} [lindex $words 2]] && \ + ![regexp {^[{"]?\s*["}]?$} [lindex $words 3]]} { + # OK + } elseif {$cmd eq "oo::class"} { + # OK + } elseif {$cmd eq "package"} { + # OK + } else { + set ns [currentNamespace] + set syn "" + if {$ns eq "" && [info exists ::syntax($cmd)]} { + set syn $::syntax($cmd) + } else { + set rescmd [lookForCommand $cmd $ns $index] + if {[llength $rescmd] > 0 && \ + [info exists ::syntax([lindex $rescmd 0])]} { + set cmd [lindex $rescmd 0] + set syn $::syntax($cmd) + } + } + if {[lsearch -glob $syn d*] >= 0} { + #echo "Firstpass '[lindex $words 0]' '$syn'" + # OK + } else { + #echo "Firstpass block1 '[lindex $words 0]' '$syn'" + return "" + } + } + } + + set type "" + set words2 {} + set wordstatus {} + set wordtype {} + set indices2 {} + set wordCnt -1 + foreach word $words index $indices { + incr wordCnt + set ws 0 + set wtype "" + if {[string length $word] > 3 && [string match "{\\*}*" $word]} { + set ws 8 + set word [string range $word 3 end] + incr index 3 + } + set char [string index $word 0] + if {$char eq "\{"} { + incr ws 3 ;# Braced & constant + set word [string range $word 1 end-1] + incr index + } else { + if {$char eq "\""} { + set word [string range $word 1 end-1] + incr index + incr ws 4 + } + if {[parseSubst $word $index wtype knownVars]} { + # A constant + incr ws 1 + } + if {$wordCnt > 0 && [string index $word 0] eq "\}"} { + errorMsg N "Unescaped close brace" $index + } + } + if {($ws & 9) == 9} { + # An expanded constant, unlikely but we can just as well handle it + if {[catch {llength $word}]} { + errorMsg E "Expanded word is not a valid list." $index + } else { + foreach apa $word { + lappend words2 $apa + lappend wordstatus 1 + lappend wordtype "" + # For now I don't bother to track correct indices + lappend indices2 $index + } + } + } else { + lappend words2 $word + lappend wordstatus $ws + lappend wordtype $wtype + lappend indices2 $index + } + } + + set cmd [lindex $words2 0] + set index [lindex $indices2 0] + set cmdtype [lindex $wordtype 0] + set cmdws [lindex $wordstatus 0] + + # Expanded command, nothing to check... + set thisCmdHasBeenHandled 0 + if {($cmdws & 8)} { + set thisCmdHasBeenHandled 1 + } + + # If the command contains substitutions we can not determine + # which command it is, so we skip it, unless the type is known + # to be an object. + + if {$thisCmdHasBeenHandled == 0 && ($cmdws & 1) == 0} { + if {[string match "_obj,*" $cmdtype]} { + set cmd $cmdtype + } else { + # Detect missing space after command + if {[regexp {^[\w:]+\{} $cmd]} { + errorMsg W "Suspicious command \"$cmd\"" $index + } + # Detect bracketed command + if {[llength $words2] == 1 && [string index $cmd 0] eq "\["} { + errorMsg N "Suspicious brackets around command" $index + } + set thisCmdHasBeenHandled 1 + } + } + + # Extract the argument parts + set argv [lrange $words2 1 end] + set wordtype [lrange $wordtype 1 end] + set wordstatus [lrange $wordstatus 1 end] + set indices [lrange $indices2 1 end] + set argc [llength $argv] + + # Find the expanded arguments + set expandWords {} + set i 0 + foreach ws $wordstatus { + if {$ws & 8} { + lappend expandWords $i + } + incr i + } + + # The parsing below can pass information to the constants checker + # This list primarily consists of args that are supposed to be variable + # names without a $ in front. + set noConstantCheck 0 + set constantsDontCheck {} + + # Any command that can't be described in the syntax database + # have their own special check implemented here. + # Any command that can be checked by checkCommand should + # be in the syntax database. + + # checkSpecial is coded as if inline, might affect these vars: + # noConstantCheck constantsDontCheck type + if {$thisCmdHasBeenHandled == 0} { + set thisCmdHasBeenHandled [checkSpecial $cmd $index $argv $wordstatus \ + $wordtype $indices $expandWords] + } + if {$thisCmdHasBeenHandled == 2} return + + # Fallthrough + if {!$thisCmdHasBeenHandled} { + set ns [currentNamespace] + if {$ns eq "" && [info exists ::syntax($cmd)]} { +# decho "Checking '$cmd' in '$ns' res" + set type [checkCommand $cmd $index $argv $wordstatus \ + $wordtype $indices $expandWords] + } else { + # Resolve commands in namespace + set rescmd [lookForCommand $cmd $ns $index] + if {$ns ne ""} { + #decho "Checking '$cmd' in '$ns' resolved '$rescmd'" + } + if {[llength $rescmd] > 0 && \ + [info exists ::syntax([lindex $rescmd 0])]} { + set cmd [lindex $rescmd 0] + # If lookForCommand returns a partial command, fill in + # all lists accordingly. + if {[llength $rescmd] > 1} { + set preargv {} + set prews {} + set prewt {} + set preindices {} + foreach arg [lrange $rescmd 1 end] { + lappend preargv $arg + lappend prews 1 + lappend prewt "" + lappend preindices $index + } + set argv [concat $preargv $argv] + set wordstatus [concat $prews $wordstatus] + set wordtype [concat $prewt $wordtype] + set indices [concat $preindices $indices] + } + set type [checkCommand $cmd $index $argv $wordstatus \ + $wordtype $indices $expandWords] + } elseif {$::Nagelfar(dbpicky)} { + errorMsg N "DB: Missing syntax for command \"$cmd\"" 0 + } + } + } + + if {$::Prefs(noVar)} { + return $type + } + + if {!$noConstantCheck} { + # Check unmarked constants against known variables to detect missing $. + # The constant is considered ok if within quotes. + set i 0 + foreach ws $wordstatus var $argv { + # is it an array? + set varBase $var + set ix [string first "(" $var] + if {$ix != -1} { + incr ix -1 + set varBase [string range $var 0 $ix] + # Check if the base is free from substitutions + if {($ws & 1) == 0 && [regexp {^(::)?(\w+(::)?)+$} $varBase]} { + set ws [expr {$ws | 1}] + } + } + if {[dict exists $knownVars $varBase]} { + if {($ws & 7) == 1 && [lsearch $constantsDontCheck $i] == -1} { + errorMsg W "Found constant \"$varBase\" which is also a\ + variable." [lindex $indices $i] + } + } + incr i + } + } + return $type +} + +# Split a script into individual statements +proc splitScript {script index statementsName indicesName} { + upvar $statementsName statements $indicesName indices + + set statements {} + set indices {} + + # tryline accumulates from the script until it becomes a complete statement + set tryline "" + # newstatement indicates that we are beginning a statement. It is equivalent + # to tryline being empty + set newstatement 1 + # firstline stores the first line of a statement + set firstline "" + # alignedBraceIx stores the position of any close braced encountered that + # is indented the same as the statement being parsed + set alignedBraceIx -1 + # openBraceIx stores the position of the last open brace at end of line + set openBraceIx -1 + # Bracelevel is used to switch parsing style depending on where we are + # brace-balance wise. This is to quickly parse large brace-enclosed blocks + # like a proc body. + set bracelevel 0 + + foreach line [split $script \n] { + # Here we must remember that "line" misses the \n that split ate. + # When line is used below we add \n. + # The extra \n generated on the last line does not matter. + + if {$bracelevel > 0} { + # Manual brace parsing is entered when we know we are in + # a braced block. Return to ordinary parsing as soon + # as a balanced brace is found. + + # Extract relevant characters + foreach char [regexp -all -inline {\\.|{|}} $line] { + if {$char eq "\{"} { + incr bracelevel + } elseif {$char eq "\}"} { + incr bracelevel -1 + if {$bracelevel <= 0} break + } + } + # Remember a close brace that is aligned with start of line. + if {"\}" eq [string trim $line] && $alignedBraceIx == -1} { + set closeBraceIx [expr {[string length $tryline] + $index}] + set closeBraceIndent [wasIndented $closeBraceIx] + set startIndent [wasIndented $index] + if {$startIndent == $closeBraceIndent} { + set alignedBraceIx $closeBraceIx + } + } + if {$bracelevel > 0} { + # We are still in a braced block so go on to the next line + append tryline $line\n + set newstatement 0 + set line "" + continue + } + } + + # An empty line can never cause completion, since at this stage + # any backslash-newline has been removed. + if {[string is space $line]} { + if {$tryline eq ""} { + # We have not started a statement yet, move index to next line. + incr index [string length $line] + incr index + } else { + append tryline $line\n + } + continue + } + + append line \n + + # This loop gradually moves parts from line to tryline until + # tryline becomes a complete statement. + # This could generate multiple statements until line is consumed. + while {$line ne ""} { + + # Some extra checking on close braces to help finding + # brace mismatches + set closeBraceIndent -1 + if {"\}" eq [string trim $line]} { + set closeBraceIx [expr {[string length $tryline] + $index}] + if {$newstatement} { + errorMsg E "Unbalanced close brace found" $closeBraceIx + reportCommentBrace 0 $closeBraceIx + } + set closeBraceIndent [wasIndented $closeBraceIx] + if {$alignedBraceIx == -1} { + set startIndent [wasIndented $index] + if {$startIndent == $closeBraceIndent} { + set alignedBraceIx $closeBraceIx + } + } + } + + # Move everything up to the next semicolon, newline or eof + # to tryline. Since newline and eof only happens at end of line, + # we only need to search for semicolon. + + set i [string first ";" $line] + if {$i != -1} { + append tryline [string range $line 0 $i] + if {$newstatement} { + set newstatement 0 + set firstline [string range $line 0 $i] + } + incr i + set line [string range $line $i end] + set splitSemi 1 + } else { + append tryline $line + if {$newstatement} { + set newstatement 0 + set firstline $line + } + set line "" + set splitSemi 0 + } + # If we split at a ; we must check that it really may be an end + if {$splitSemi} { + # Comment lines don't end with ; + #if {[regexp {^\s*#} $tryline]} {continue} + if {[string index [string trimleft $tryline] 0] eq "#"} continue + + # Look for \'s before the ; + # If there is an odd number of \, the ; is ignored + if {[string index $tryline end-1] eq "\\"} { + set i [expr {[string length $tryline] - 2}] + set t $i + while {[string index $tryline $t] eq "\\"} { + incr t -1 + } + if {($i - $t) % 2 == 1} {continue} + } + } + # Check if it's a complete line + if {[info complete $tryline]} { + # Remove leading space, keep track of index. + # Most lines will have no leading whitespace since + # buildLineDb removes most of it. This takes care + # of all remaining. + if {[string is space -failindex i $tryline]} { + # Only space, discard the line + incr index [string length $tryline] + set tryline "" + set newstatement 1 + set alignedBraceIx -1 + continue + } else { + if {$i != 0} { + set tryline [string range $tryline $i end] + incr index $i + } + } + # Take care of the statement + # Comments are added to the statement list and checked later + if {$splitSemi} { + # Remove the semicolon from the statement + lappend statements [string range $tryline 0 end-1] + } else { + lappend statements $tryline + } + lappend indices $index + + # Extra checking if the last line of the statement was + # a close brace. + if {$closeBraceIndent != -1} { + # Check if the close brace is aligned with start of command + set tmp [wasIndented $index] + if {$tmp != $closeBraceIndent} { + set tmp2 [wasIndented $openBraceIx] + # Matching last open brace is ok too + if {$openBraceIx == -1 || $closeBraceIndent != $tmp2} { + # Only do this if there is a free open brace + if {[regexp "\{\n" $tryline]} { + errorMsg N "Close brace not aligned with line\ + [calcLineNo $index]\ + ($tmp $closeBraceIndent)" \ + $closeBraceIx + } + } + } + } + incr index [string length $tryline] + set tryline "" + set newstatement 1 + set alignedBraceIx -1 + } elseif {$closeBraceIndent == 0 && \ + ![string match "namespace eval*" $tryline] && \ + ![string match "if *" $tryline] && \ + ![string match "*tcl_platform*" $tryline]} { + # A close brace that is not indented is typically the end of + # a global statement, like "proc". + # If it does not end the statement, there is probably a + # brace mismatch. + # When inside a namespace eval block, this is probably ok. + errorMsg N "Found non indented close brace that did not end\ + statement." $closeBraceIx + contMsg "This may indicate a brace mismatch." + } + } ;# End of loop means line used up + + # If the line is complete except for a trailing open brace + # we can switch to just scanning braces. + # This could be made more general but since this is the far most + # common case it's probably not worth complicating it. + if {[string range $tryline end-2 end] eq " \{\n" && \ + [info complete [string range $tryline 0 end-2]]} { + set openBraceIx [expr {[string length $tryline] + $index - 1}] + set bracelevel 1 + } + } + # If tryline is non empty, it did not become complete + if {[string length $tryline] != 0} { + errorMsg E "Could not complete statement." $index + + # Experiment a little to give more info. + # First, at first line, to give a hint of the nature of what is missing. + if {[info complete $firstline\}]} { + contMsg "One close brace would complete the first line" + reportCommentBrace $index $index + } elseif {[info complete $firstline\}\}]} { + contMsg "Two close braces would complete the first line" + reportCommentBrace $index $index + } + if {[info complete $firstline\"]} { + contMsg "One double quote would complete the first line" + } + if {[info complete $firstline\]]} { + contMsg "One close bracket would complete the first line" + } + + # Second, at an aligned close brace, which is a likely place. + if {$alignedBraceIx != -1} { + set cand [string range $tryline 0 [expr {$alignedBraceIx - $index}]] + set txt "at end of line [calcLineNo $alignedBraceIx]." + if {[info complete $cand\}]} { + contMsg "One close brace would complete $txt" + } elseif {[info complete $cand\}\}]} { + contMsg "Two close braces would complete $txt" + } + # TODO: Use this information to assume completeness earlier + # This would need to recurse back to this function after cutting of the + # remainder of tryline. + } + + # Third, at end of script + set endIx [expr {$index + [string length $tryline] - 1}] + set txt "the script body at line [calcLineNo $endIx]." + if {[info complete $tryline\}]} { + contMsg "One close brace would complete $txt" + contMsg "Assuming completeness for further processing." + reportCommentBrace $index $endIx + lappend statements $tryline\} + lappend indices $index + } elseif {[info complete $tryline\}\}]} { + contMsg "Two close braces would complete $txt" + contMsg "Assuming completeness for further processing." + reportCommentBrace $index $endIx + lappend statements $tryline\}\} + lappend indices $index + } + if {[info complete $tryline\"]} { + contMsg "One double quote would complete $txt" + } + if {[info complete $tryline\]]} { + contMsg "One close bracket would complete $txt" + } + } +} + +# Returns the return type of the script +proc parseBody {body index knownVarsName {warnCommandSubst 0}} { + upvar $knownVarsName knownVars + + # Cache the splitScript result to optimise 2-pass checking. + if {[info exists ::Nagelfar(cacheBody)] && \ + [info exists ::Nagelfar(cacheBody,$body)]} { + set statements $::Nagelfar(cacheStatements,$body) + set indices $::Nagelfar(cacheIndices,$body) + } else { + splitScript $body $index statements indices + } + # Unescaped newline in command substitution body is probably wrong + if {$warnCommandSubst && [llength $statements] > 1} { + foreach statement [lrange $statements 0 end-1] \ + stmtIndex [lrange $indices 0 end-1] { + if {[string index $statement end] eq "\n"} { + # Comment is ok + if {[string index $statement 0] ne "\#"} { + errorMsg N "Newline in command substitution" $stmtIndex + break + } + } + } + } + + #puts "Parsing a body with [llength $statements] stmts" + set type "" + foreach statement $statements index $indices { + if {[string match "#*" $statement]} { + checkComment $statement $index knownVars + } else { + set type [parseStatement $statement $index knownVars] + } + } + if {$::Nagelfar(firstpass)} { + set ::Nagelfar(cacheBody) 1 + set ::Nagelfar(cacheBody,$body) 1 + set ::Nagelfar(cacheStatements,$body) $statements + set ::Nagelfar(cacheIndices,$body) $indices + } else { + # FIXA: Why is this here? Tests pass without it + unset -nocomplain ::Nagelfar(cacheBody) + } + return $type +} + +# This is called when a definition command is encountered +# Add arguments to variable scope +proc parseArgs {procArgs indexArgs syn knownVarsName} { + upvar $knownVarsName knownVars + + if {[catch {llength $procArgs}]} { + errorMsg E "Argument list is not a valid list" $indexArgs 1 + set procArgs {} + } + # Do not loop $syn in the foreach command since it can be shorter + set seenDefault 0 + set i -1 + foreach a $procArgs { + incr i + set var [lindex $a 0] + if {[llength $a] > 1} { + set seenDefault 1 + } elseif {$seenDefault && $var ne "args"} { + errorMsg N "Non-default arg after default arg" $indexArgs 1 + # Reset to avoid further messages + set seenDefault 0 + } + knownVar knownVars $var + dict set knownVars $var local 1 + dict set knownVars $var set 1 + SplitToken [lindex $syn $i] tok _ type _ _ _ + if {$type eq "" && $tok in {v n l}} { + # The token indicates a variable name + set type "varName" + } + dict set knownVars $var "type" $type + } + + # Sanity check of argument names + if {!$::Nagelfar(firstpass)} { + # Check for non-last "args" + set i [lsearch $procArgs "args"] + if {$i >= 0 && $i != [llength $procArgs] - 1} { + errorMsg N "Argument 'args' used before last, which can be confusing" \ + $indexArgs + } + # Check for duplicates + set l1 [lsort $procArgs] + set l2 [lsort -unique $procArgs] + if {$l1 ne $l2} { + errorMsg N "Duplicate proc arguments" $indexArgs + } + } +} + +# Create a syntax definition from args list, and given the info +# about variables in the body. +proc parseArgsToSyn {name procArgs indexArgs syn knownVars} { + + if {[catch {llength $procArgs}]} { + # This is reported elsewhere + set procArgs {} + } + + # Build a syntax description for the procedure. + # Parse the arguments. + set upvared 0 + set unlim 0 + set min 0 + set newsyntax {} + foreach a $procArgs { + set var [lindex $a 0] + set type x + + # Check for any upvar in the proc + if {[dict get $knownVars $var upvar] ne ""} { + set other [dict get $knownVars $var upvar] + if {[dict get $knownVars $other read]} { + set type v + } elseif {[dict get $knownVars $other set]} { + set type n + } else { + set type l + } + set upvared 1 + } + if {$var eq "args"} { + set unlim 1 + set type x* + } elseif {[llength $a] == 2} { + append type . + } else { + incr min + } + lappend newsyntax $type + } + + if {!$upvared} { + if {$unlim} { + set newsyntax [list r $min] + } elseif {$min == [llength $procArgs]} { + set newsyntax $min + } else { + set newsyntax [list r $min [llength $procArgs]] + } + } + + if {$syn ne ""} { + # Check if it matches previously defined syntax + set prevmin 0 + set prevmax 0 + set prevunlim 0 + if {[string is integer $syn]} { + set prevmin $syn + set prevmax $syn + } elseif {[string match "r*" $syn]} { + set prevmin [lindex $syn 1] + set prevmax [lindex $syn 2] + if {$prevmax == ""} { + set prevmax $prevmin + set prevunlim 1 + } + } else { + foreach token $syn { + # Look for multi token + if {[regexp {&.*(.)$} $token -> mod]} { + if {$mod == "?"} { + incr prevmax 2 + } elseif {$mod == "*"} { + set prevunlim 1 + } + continue + } + SplitToken $token tok tokCount _ mod n _ + if {$mod == ""} { + incr prevmin $n + incr prevmax $n + } elseif {$mod == "?"} { + incr prevmax $n + } elseif {$mod == "*"} { + set prevunlim 1 + } elseif {$mod == "."} { + incr prevmax $n + } + } + } + if {$prevunlim != $unlim || \ + ($prevunlim == 0 && $prevmax != [llength $procArgs]) \ + || $prevmin != $min} { + errorMsg W "Procedure \"$name\" does not match previous definition" \ + $indexArgs 1 + contMsg "Previous '$syn' New '$newsyntax'" + set newsyntax $syn + } else { + # It matched. Does the new one seem better? + if {[regexp {^(?:r )?\d+(?: \d+)?$} $syn]} { + #if {$syntax($name) != $newsyntax} { + # decho "$name : Prev: '$syntax($name)' New: '$newsyntax'" + #} + # decho "Syntax for '$name' : '$newsyntax'" + #set syntax($name) $newsyntax + } else { + set newsyntax $syn + } + } + } else { + # decho "Syntax for '$name' : '$newsyntax'" + #set syntax($name) $newsyntax + } + return $newsyntax +} + +# Look for implicit variables for the surrounding namespace +proc addImplicitVariablesNs {cmd index knownVarsName} { + upvar $knownVarsName knownVars + set cNs [currentNamespace] + set cNsC ${cNs}::[namespace tail $cmd] + set impVar {} + if {[info exists ::implicitVarNs($cNsC)]} { + set impVar $::implicitVarNs($cNsC) + } elseif {[info exists ::implicitVarNs($cNs)]} { + set impVar $::implicitVarNs($cNs) + } else { + #decho "Looking for implicit in '$cNsC' '$cNs'" + #parray ::implicitVarNs + } + #echo "addImplicitVariablesNs $cmd $impVar" + foreach var $impVar { + set varName [lindex $var 0] + set type [lindex $var 1] + markVariable $varName 1 "" 1n \ + $index unknown knownVars type + # not every implicit var is used inside a method + # so always mark as used + setVarUsed knownVars $varName + } +} + +# Look for implicit variables for this command +proc addImplicitVariablesCmd {cmd index knownVarsName} { + if {[array size ::implicitVarCmd] == 0} return + upvar $knownVarsName knownVars + foreach pattern [array names ::implicitVarCmd] { + set impVar {} + if {[string match $pattern $cmd]} { + eval lappend impVar $::implicitVarCmd($pattern) + } + foreach var $impVar { + set varName [lindex $var 0] + set type [lindex $var 1] + markVariable $varName 1 "" 1n \ + $index unknown knownVars type + } + } +} + +# This is called when a proc command is encountered. +# It is assumed that argv and indices has three elements. +proc parseProc {argv indices isProc isMethod definingCmd} { + global knownGlobals syntax + + foreach {name argList body} $argv break + + set nameMethod "" + if {$isMethod} { + set currentObj [currentObject] + if {$currentObj eq ""} { + errorMsg N "Method definition without a current object" \ + [lindex $indices 0] + set isMethod 0 + } else { + lappend ::subCmd($currentObj) $name + #echo "Adding $::Nagelfar(firstpass) '$name' to '$currentObj' -> '$::subCmd($currentObj)'" + set nameMethod "$currentObj $name" + } + } + + # Take care of namespace + set cns [currentNamespace] + set ns [namespace qualifiers $name] + set tail [namespace tail $name] + set storeIt $isProc + if {![string match "::*" $ns]} { + if {$cns eq "__unknown__"} { + set ns $cns + set storeIt 0 + } elseif {$ns != ""} { + set ns ${cns}::$ns + } else { + set ns $cns + } + } + set fullname ${ns}::$tail + #decho "proc $name -> $fullname ($cns) ($ns) ($tail)" + # Do not include the first :: in the name + if {[string match ::* $fullname]} { + set fullname [string range $fullname 2 end] + } + set name $fullname + + # Parse the arguments. + # Initialise a knownVars dict with the arguments. + set knownVars {} + + # Scan the syntax definition in parallel to look for types + if {$isProc && [info exists syntax($name)]} { + set syn $syntax($name) + } elseif {$isMethod && [info exists syntax($nameMethod)]} { + set syn $syntax($nameMethod) + } else { + set syn "" + } + + parseArgs $argList [lindex $indices 1] $syn knownVars + + if {$storeIt} { + lappend ::knownCommands $name + } + addImplicitVariablesNs $definingCmd [lindex $indices 0] knownVars + + # Look in the calling environment for known globals with types. + # TODO: Better handling of known globals. + upvar 1 "knownVars" envKnownVars + dict for {var i} $envKnownVars { + set type [dict get $i type] + if {![dict get $i local] && $type ne ""} { + dict set knownVars $var $i + } + } + +# decho "Note: parsing procedure $name" + if {!$::Nagelfar(firstpass)} { + if {$isProc} { + pushNamespace $ns + } + pushProc $name + parseBody $body [lindex $indices 2] knownVars + if {[string trim $body] ne ""} { + # check only if not an empty 'dummy' function + checkForUnusedVar knownVars [lindex $indices 0] + } + popProc + if {$isProc} { + popNamespace + } + } + instrumentL $indices $argv 2 + + set newSyn [parseArgsToSyn $name $argList [lindex $indices 1] \ + $syn $knownVars] + if {$storeIt} { + set syntax($name) $newSyn + } + if {$isMethod} { + if {[info exists syntax($nameMethod)]} { + #echo "Overwriting $nameMethod from '$syn' with '$newSyn'" + } else { + #echo "Writing $nameMethod from '$syn' with '$newSyn'" + } + set syntax($nameMethod) $newSyn + } + + # Update known globals with those that were set in the proc. + # I.e. anyone with set == 1 and namespace == "" should be + # added to known globals. + foreach var [dict keys $knownVars] { + if {[dict get $knownVars $var local]} continue + if {![dict get $knownVars $var set]} continue + set ns [dict get $knownVars $var namespace] +# decho "Set global $var in ns $ns in proc $name." + if {$ns eq "" && [lsearch $knownGlobals $var] == -1} { + lappend knownGlobals $var + } + } + return $newSyn +} + +# Given an index in the original string, calculate its line number. +proc calcLineNo {ix} { + global newlineIx + + # Shortcut for exact match, which happens when the index is first + # in a line. This is common when called from wasIndented. + set i [lsearch -integer -sorted $newlineIx $ix] + if {$i >= 0} { + return [expr {$i + 2}] + } + + # Binary search + if {$ix < [lindex $newlineIx 0]} {return 1} + set first 0 + set last [expr {[llength $newlineIx] - 1}] + if {$last < 0} {set last 0} + + while {$first < ($last - 1)} { + set n [expr {($first + $last) / 2}] + set ni [lindex $newlineIx $n] + if {$ni < $ix} { + set first $n + } elseif {$ni > $ix} { + set last $n + } else { + # Equality should have been caught in the lsearch above. + decho "Internal error: Equal element slipped through in calcLineNo" + return [expr {$n + 2}] + } + } + return [expr {$last + 1}] +} + +# Given an index in the original string, tell if that line was indented +# This should preferably be called with the index to the first char of +# the line since that case is much more efficient in calcLineNo. +proc wasIndented {i} { + lindex $::indentInfo [calcLineNo $i] +} + +# Length of initial whitespace +proc countIndent {str} { + # Get whitespace + set str [string range $str 0 end-[string length [string trimleft $str]]] + # Any tabs? + if {[string first \t $str] != -1} { + # Only tabs in beginning? + if {[regexp {^\t+[^\t]*$} $str]} { + set str [string map $::Nagelfar(tabMap) $str] + } else { + regsub -all $::Nagelfar(tabReg) $str $::Nagelfar(tabSub) str + } + } + return [string length $str] +} + +# Build a database of newlines to be able to calculate line numbers. +# Also replace all escaped newlines with a space, and remove all +# whitespace from the start of lines. Later processing is greatly +# simplified if it does not need to bother with those. +# Returns the simplified script. +proc buildLineDb {str} { + global newlineIx indentInfo + + set result "" + set lines [split $str \n] + if {[lindex $lines end] eq ""} { + set lines [lrange $lines 0 end-1] + } + set newlineIx {} + # Dummy element to get 1.. indexing + set indentInfo [list {}] + + # Detect a header. Backslash-newline is not substituted in the header, + # and the index after the header is kept. This is to preserve the header + # in code coverage mode. + # The first non-empty non-comment line ends the header. + set ::instrumenting(header) 0 + set ::instrumenting(already) 0 + set headerLines 1 + set previousWasEscaped 0 + + # This is a trick to get "sp" and "nl" to get an internal string rep. + # This also makes sure it will not be a shared object, which can mess up + # the internal rep. + # Append works a lot better that way. + set sp [string range " " 0 0] + set nl [string range \n 0 0] + set lineNo 0 + set lastCmdLine "" + + foreach line $lines { + incr lineNo + # Count indent spaces and remove them + set indent [countIndent $line] + set line [string trimleft $line] + if {$::Nagelfar(lineLen) > 0} { + if {$indent + [string length $line] > $::Nagelfar(lineLen)} { + errorMsg W "Too long line" [string length $result] + } + } + if {!$previousWasEscaped} { + set lastCmdLine $line + } + # Check for comments. + if {[string index $line 0] eq "#"} { + # Make notes about unbalanced braces in comments + checkPossibleComment $line $lineNo + # A # in the middle of backslash-newline rows is suspicious. + if {$previousWasEscaped} { + if {[string index $lastCmdLine 0] ne "#"} { + errorMsg N "Suspicious \# char. Possibly a bad comment." \ + [string length $result] + } + } + } + # Keep track of the leading comment lines (header) to preserve them + # when instrumenting for coverage. + if {[string index $line 0] eq "#" && \ + ![string match "##nagelfar *" $line]} { + # Do nothing, this can be a header line + # Inline comment pragmas are not considered part of a header + } elseif {$headerLines && $line ne "" && !$previousWasEscaped} { + set headerLines 0 + set ::instrumenting(header) [string length $result] + if {$line eq "namespace eval ::_instrument_ {}"} { + set ::instrumenting(already) 1 + } + } + + # Count backslashes to determine if it's escaped + set previousWasEscaped 0 + if {[string index $line end] eq "\\"} { + set len [string length $line] + set si [expr {$len - 2}] + while {[string index $line $si] eq "\\"} {incr si -1} + if {($len - $si) % 2 == 0} { + # An escaped newline + set previousWasEscaped 1 + if {!$headerLines} { + append result [string range $line 0 end-1] $sp + lappend newlineIx [string length $result] + lappend indentInfo $indent + continue + } + } + } + # Unescaped newline + # It's important for performance that all elements in append + # has an internal string rep. String index takes care of $line + append result $line $nl + lappend newlineIx [string length $result] + lappend indentInfo $indent + } + if {$::Nagelfar(gui)} {progressMax $lineNo} + return $result +} + +# Parse a global script +proc parseScript {script} { + global knownGlobals unknownCommands knownCommands syntax + + catch {unset unknownCommands} + set unknownCommands {} + set knownVars {} + array set ::knownAliases {} + array set ::namespacePaths {} + foreach g $knownGlobals { + knownVar knownVars $g + dict set knownVars $g set 1 + } + set ::Nagelfar(firstpass) 0 + set script [buildLineDb $script] + set ::instrumenting(script) $script + + pushNamespace {} + if {$::Nagelfar(2pass)} { + # First do one round with proc checking + set ::Nagelfar(firstpass) 1 + parseBody $script 0 knownVars + #echo "Second pass" + set ::Nagelfar(firstpass) 0 + } + parseBody $script 0 knownVars + popNamespace + + # Check commands that where unknown when encountered + # FIXA: aliases + foreach apa $unknownCommands { + foreach {cmd cmds index} $apa break + set found 0 + foreach cmdCandidate $cmds { + if {[info exists syntax($cmdCandidate)] || \ + [lsearch $knownCommands $cmdCandidate] >= 0} { + set found 1 + break + } + } + if {!$found} { + # Close brace is reported elsewhere + if {$cmd ne "\}"} { + # Different messages depending on name + if {[regexp {^(?:(?:[\w',:.-]+)|(?:%W))$} $cmd]} { + errorMsg W "Unknown command \"$cmd\"" $index + } else { + errorMsg E "Strange command \"$cmd\"" $index + } + } + } + } + # Update known globals. + # FIXA: This should transfer any known types + foreach var [dict keys $knownVars] { + if {[dict get $knownVars $var namespace] != ""} continue + if {[dict get $knownVars $var local]} continue + # Check if it has been set. + if {[dict get $knownVars $var set]} { + if {[lsearch $knownGlobals $var] == -1} { + lappend knownGlobals $var + } + } + } +} + +# Parse a file +proc parseFile {filename} { + set ch [open $filename] + if {[info exists ::Nagelfar(encoding)] && \ + $::Nagelfar(encoding) ne "system"} { + fconfigure $ch -encoding $::Nagelfar(encoding) + } + set script [read $ch] + close $ch + + # Check for Ctrl-Z + set i [string first \u001a $script] + if {$i >= 0} { + # Cut off the script as source would do + set script [string range $script 0 [expr {$i - 1}]] + } + + array unset ::instrumenting + + initMsg + parseScript $script + if {$i >= 0} { + # Add a note about the Ctrl-Z + errorMsg N "Aborted script due to end-of-file marker" \ + [expr {[string length $::instrumenting(script)] - 1}] + } + flushMsg + + if {$::Nagelfar(instrument) && \ + [file extension $filename] ne ".syntax"} { + # Experimental instrumenting + dumpInstrumenting $filename + } +} + +# Find an element that is less than or equal, in a decreasing sorted list +proc binSearch {sortedList ix} { + # Shortcut for exact match + set i [lsearch -decreasing -integer -sorted $sortedList $ix] + if {$i >= 0} { + return $i + } + + # Binary search + if {$ix > [lindex $sortedList 0]} {return 0} + set first 0 + set last [expr {[llength $sortedList] - 1}] + if {$ix < [lindex $sortedList end]} {return -1} + + while {$first < ($last - 1)} { + set n [expr {($first + $last) / 2}] + set ni [lindex $sortedList $n] + if {$ni > $ix} { + set first $n + } elseif {$ni < $ix} { + set last $n + } else { + # Equality should have been caught in the lsearch above. + decho "Internal error: Equal element slipped through in binSearch" + return [expr {$n + 1}] + } + } + return $last +} + +# Store information for instrumenting +# TODO: Maybe replace these with dummies when instrumenting is off? +proc instrument {index value body} { + set ::instrumenting($index) $value + # Remember the end of block + set ::instrumenting(end,$index) [expr {$index + [string length $body] -1}] +} +# List version of instrument, since many callers need this structure. +proc instrumentL {indices argv i} { + instrument [lindex $indices $i] 1 [lindex $argv $i] +} + +# Decide for an identifying name for a file. +# TODO: Maybe use whole path? Does it matter? +proc instrumentId {filename tailName idStringName baseName} { + upvar 1 $tailName tail $idStringName idString $baseName base + set fullname [file normalize [file join [pwd] $filename]] + set tail [file tail $fullname] + set parts [file split $fullname] + set lastParts [lrange $parts end-2 end] + set idString [file join {*}$lastParts] + set base $filename + if {$::Nagelfar(idir) ne ""} { + file mkdir $::Nagelfar(idir) + # TODO: Should any part of file's path be included under idir? + set base [file join $::Nagelfar(idir) $tail] + } +} + +# Write source instrumented for code coverage +proc dumpInstrumenting {filename} { + instrumentId $filename tail idString base + if {$::instrumenting(already)} { + echo "Warning: Instrumenting already instrumented file $tail" + } + set iFile ${base}_i + set logFile ${base}_log + echo "Writing file $iFile" 1 + set iscript $::instrumenting(script) + set indices {} + foreach item [array names ::instrumenting] { + if {[string is digit $item]} { + lappend indices $item + } + } + set indices [lsort -decreasing -integer $indices] + # Look for lines marked with nocover + foreach item [array names ::instrumenting no,*] { + set index [lindex [split $item ","] end] + set i [binSearch $indices $index] + if {$i < 0} continue + # Default range to delete is one item + set iEnd $i + # Any end to extend range to? + set indexStart [lindex $indices $i] + if {[info exists ::instrumenting(end,$indexStart)]} { + set indexEnd $::instrumenting(end,$indexStart) + set i2 [binSearch $indices $indexEnd] + if {$i2 >= 0 && $i2 <= $i} { + set iEnd $i2 + } + } + # Indices are decreasing so iEnd is first + set indices [lreplace $indices $iEnd $i] + } + set init {} + lappend init [list set current $idString] + lappend init [list set idir $::Nagelfar(idir)] + lappend init [list set "logFile" $logFile] + set headerIndex $::instrumenting(header) + foreach ix $indices { + # Indices goes backwards here, so when reaching headerIndex we are done + if {$ix <= $headerIndex} break + set line [calcLineNo $ix] + set item "$idString,$line" + set i 2 + while {[info exists done($item)]} { + set item "$idString,$line,$i" + incr i + } + set done($item) 1 + set default 0 + + if {[llength $::instrumenting($ix)] > 1} { + foreach {type varname} $::instrumenting($ix) break + set endix [string first \n $iscript $ix] + set pre [string range $iscript 0 [expr {$ix - 1}]] + set post [string range $iscript $endix end] + append item ",var" + set insert "[list lappend ::_instrument_::log($item)] \$[list $varname]" + set default {} + } elseif {$::instrumenting($ix) == 2} { + # Missing else clause + if {[string index $iscript $ix] eq "\}"} { + incr ix + } + # To make the instrumentation side effect free the else clause + # returns an empty string by adding the "list" command at the end. + set insert [list incr ::_instrument_::log($item)]\;list + set insert " [list else $insert]" + set pre [string range $iscript 0 [expr {$ix - 1}]] + set post [string range $iscript $ix end] + } else { + # Normal + set insert [list incr ::_instrument_::log($item)]\; + set pre [string range $iscript 0 [expr {$ix - 1}]] + set post [string range $iscript $ix end] + + set c [string index $pre end] + if {$c ne "\[" && $c ne "\{" && $c ne "\"" && $c ne "+"} { + if {[regexp {^(\s*\w+)(\s.*)$} $post -> word rest]} { + append pre "\{" + set post "$word\}$rest" + } else { + echo "Not instrumenting line: $line\ + [string range $pre end-5 end]<>[string range $post 0 5]" + continue + } + } + } + set iscript $pre$insert$post + + lappend init [list set log($item) $default] + } + set ch [open $iFile w] + if {[info exists ::Nagelfar(encoding)] && \ + $::Nagelfar(encoding) ne "system"} { + fconfigure $ch -encoding $::Nagelfar(encoding) + } + # Start with a copy of the original's header + if {$headerIndex > 0} { + puts $ch [string range $iscript 0 [expr {$headerIndex - 1}]] + set iscript [string range $iscript $headerIndex end] + } + # Create a prolog equal in all instrumented files + # The first line is indented with one space to make it detectable when + # looking for an instrumented file + puts $ch { namespace eval ::_instrument_ {}} + puts $ch [list set ::_instrument_::replaceSource \ + [expr {!$::Nagelfar(nosource)}]] + puts $ch [info body _instrumentProlog1] + # Insert file specific info + # This is only initialised first time a file is sourced + puts $ch "if {!\[[list info exists ::_instrument_::doneFile($idString)]\]} \{" + puts $ch [list set ::_instrument_::doneFile($idString) 1] + + puts $ch "# Initialise list of lines" + puts $ch "namespace eval ::_instrument_ \{" + puts $ch [join $init \n] + puts $ch "\}" + # More common prolog for file specific stuff + puts $ch [info body _instrumentProlog2] + + # End of the if doneFile block + puts $ch "\}" + + puts $ch "\#instrumented source goes here" + puts $ch $iscript + close $ch + + # Copy permissions to instrumented file. + catch {file attributes $iFile -permissions \ + [file attributes $filename -permissions]} +} + +# The body of this procedure is used as common code in instrumented files +# It is stored in a proc to be able to treat it as code in indentation and +# syntax checking. +proc _instrumentProlog1 {} { + # Defining help procedures should be done once even if multiple + # instrumented files are loaded, so check if it has been done. + if {[info commands ::_instrument_::flock] == ""} { + if {$::_instrument_::replaceSource} { + rename ::source ::_instrument_::source + ##nagelfar ignore does not match previous + proc ::source {args} { + set fileName [lindex $args end] + set args [lrange $args 0 end-1] + set newFileName $fileName + set altFileNames [list ${fileName}_i] + if {$::_instrument_::idir ne ""} { + lappend altFileNames [file join $::_instrument_::idir \ + [file tail $fileName]_i] + } + foreach altFileName $altFileNames { + if {[file exists $altFileName]} { + set newFileName $altFileName + } + } + set args [linsert $args 0 ::_instrument_::source] + lappend args $newFileName + uplevel 1 $args + } + } + rename ::exit ::_instrument_::exit + ##nagelfar ignore does not match previous + proc ::exit {args} { + ::_instrument_::cleanup + uplevel 1 [linsert $args 0 ::_instrument_::exit] + } + ##nagelfar syntax _instrument_::flock x c + proc ::_instrument_::flock {filename cmds} { + set lck ${filename}.lck + set i 0 + while { [catch {open $lck {WRONLY CREAT EXCL}} lock] } { + incr i + after 250 + if {$i > 9} { + # Warn about this but continue with next file. + # Since we are in instrumented code we only have access + # to stdout for this warning. + puts "Warning: Could not acquire lock '$lck' in $i tries!" + puts "Warning: Results from '$filename' will be lost!" + return + } + } + # Should use try in 8.6 + set errCode [catch { uplevel 1 $cmds } errMsg] + # finally + close $lock + file delete $lck + if {$errCode} { + return -code $errCode $errMsg + } + } + proc ::_instrument_::cleanup {} { + variable log + variable all + variable dumpList + foreach {src logFile} $dumpList { + flock $logFile { + # The log consists of incr/lappend commands so eval:ing it + # merges those results with current data + if {[file exists $logFile]} { + # Avoid source command + set ch [open $logFile r] + set logdata [read $ch] + close $ch + eval $logdata + } + set ch [open $logFile w] + foreach item [lsort -dictionary [array names log $src,*]] { + if {[string match *,var $item]} { + # Variable coverage is a list, not a number + puts $ch [linsert $::_instrument_::log($item) 0 \ + lappend ::_instrument_::log($item)] + } else { + puts $ch [list incr ::_instrument_::log($item) \ + $::_instrument_::log($item)] + } + set ::_instrument_::log($item) 0 + } + close $ch + } + } + } + } +} + +# The body of this procedure is used as common code in instrumented files +# It is stored in a proc to be able to treat it as code in indentation and +# syntax checking. +# Variables dumpList and current are known where this code is run, this is +# emulated by making them arguments. +proc _instrumentProlog2 {dumpList current logFile} { + # Store information about this particular file for later use in cleanup + namespace eval ::_instrument_ { + lappend dumpList $current $logFile + } +} + +# Add Code Coverage markup to a file according to measured coverage +proc instrumentMarkup {filename full} { + instrumentId $filename tail idString base + set logFile ${base}_log + set mFile ${base}_m + + namespace eval ::_instrument_ {} + source $logFile + set covered 0 + set noncovered 0 + foreach item [array names ::_instrument_::log $idString,*] { + if {[string match "*,var" $item]} { + set values [lsort -dictionary -unique $::_instrument_::log($item)] + # FIXA: Maybe support expected values check + if {[regexp {,(\d+),\d+,var$} $item -> line]} { + set lines($line) ";# $values" + } elseif {[regexp {,(\d+),var$} $item -> line]} { + set lines($line) ";# $values" + } + continue + } + if {$::_instrument_::log($item) != 0} { + incr covered + # Markup covered only if full is requested + if {$full} { + if {[regexp {,(\d+),\d+$} $item -> line]} { + set lines($line) \ + " ;# Reached $::_instrument_::log($item) times" + } elseif {[regexp {,(\d+)$} $item -> line]} { + set lines($line) \ + " ;# Reached $::_instrument_::log($item) times" + } + } + continue + } + incr noncovered + if {[regexp {,(\d+),\d+$} $item -> line]} { + set lines($line) " ;# Not covered" + } elseif {[regexp {,(\d+)$} $item -> line]} { + set lines($line) " ;# Not covered" + } + } + set total [expr {$covered + $noncovered}] + if {$total == 0} { + set coverage 100.0 + } else { + set coverage [expr {100.0 * $covered / $total}] + } + set stats [format "(%d/%d %4.1f%%)" \ + $covered $total $coverage] + echo "Writing file $mFile $stats" 1 + if {[array size lines] == 0} { + echo "All lines covered in $tail" + file copy -force $filename $mFile + return + } + + set chi [open $filename r] + set cho [open $mFile w] + if {[info exists ::Nagelfar(encoding)] && \ + $::Nagelfar(encoding) ne "system"} { + fconfigure $chi -encoding $::Nagelfar(encoding) + fconfigure $cho -encoding $::Nagelfar(encoding) + } + set lineNo 1 + while {[gets $chi line] >= 0} { + if {$line eq " namespace eval ::_instrument_ {}"} { + echo "File $filename is instrumented, aborting markup" + close $chi + close $cho + file delete $mFile + return + } + if {[info exists lines($lineNo)]} { + append line $lines($lineNo) + } + puts $cho $line + incr lineNo + } + close $chi + close $cho +} + +# Add a message filter +proc addFilter {pat {start_line -1} {end_line -1} {reapply 0}} { + set flt [list $pat $start_line $end_line] + if {[lsearch -exact $::Nagelfar(filter) $flt] < 0} { + lappend ::Nagelfar(filter) $flt + } + if {$reapply} { + set w $::Nagelfar(resultWin) + $w configure -state normal + set ln 1 + while {1} { + set tags [$w tag names $ln.0] + set tag [lsearch -glob -inline $tags "message*"] + if {$tag == ""} { + set range [list $ln.0 $ln.end+1c] + set line [$w get $ln.0 $ln.end] + } else { + set range [$w tag nextrange $tag $ln.0] + if {$range == ""} { + incr ln + if {[$w index end] <= $ln} { + break + } + continue + } + set line [eval \$w get $range] + } + if {[string match $pat $line]} { + eval \$w delete $range + } else { + incr ln + } + if {[$w index end] <= $ln} break + } + $w configure -state disabled + } +} + +# Clear out all filters +proc resetFilters {} { + set ::Nagelfar(filter) {} +} + +# FIXA: Move safe reading to package +##nagelfar syntax _ipsource x +##nagelfar syntax _ipexists l +##nagelfar syntax _ipset 1: v : n x +##nagelfar syntax _iplappend n x* +##nagelfar syntax _iparray s v +##nagelfar subcmd _iparray exists get + +# Load syntax database using safe interpreter +proc loadDatabases {{addDb {}}} { + if {[interp exists loadinterp]} { + interp delete loadinterp + } + interp create -safe loadinterp + interp expose loadinterp source + interp alias {} _ipsource loadinterp source + interp alias {} _ipexists loadinterp info exists + interp alias {} _ipset loadinterp set + interp alias {} _ipeval loadinterp eval + interp alias {} _iplappend loadinterp lappend + interp alias {} _iparray loadinterp array + if {$addDb ne ""} { + set dbs [list $addDb] + } else { + set dbs $::Nagelfar(db) + } + + set intDb [info exists ::Nagelfar(dbContents)] + if {$intDb} { + set dbs [list $::Nagelfar(dbContents)] + } + + foreach f $dbs { + # FIXA: catch? + if {$intDb} { + _ipeval $f + } else { + _ipsource $f + } + + # Support inline comments in db file + if {$intDb} { + set data $f + set f "_internal_" + } else { + set ch [open $f r] + set data [read $ch] + close $ch + } + if {[string first "##nagelfar" $data] < 0} continue + set lines [split $data \n] + set commentlines [lsearch -all $lines "*##nagelfar*"] + foreach commentline $commentlines { + set comment [lindex $lines $commentline] + set str [string trim $comment] + if {![string match "##nagelfar *" $str]} continue + + # Increase to make a line number from the index + incr commentline + set rest [string range $str 11 end] + if {[catch {llength $rest}]} { + echo "Bad list in ##nagelfar comment in db $f line $commentline" + continue + } + if {[llength $rest] == 0} continue + set cmd [lindex $rest 0] + set first [lindex $rest 1] + set rest [lrange $rest 2 end] + switch -- $cmd { + syntax { + _ipset ::syntax($first) $rest + _iplappend ::knownCommands $first + } + implicitvarns { + _ipset ::implictVarNs($first) $rest + } + implicitvarcmd { + _ipset ::implictVarCmd($first) $rest + } + return { + _ipset ::return($first) $rest + } + subcmd { + _ipset ::subCmd($first) $rest + } + subcmd+ { + eval [list _iplappend "::subCmd($first)"] $rest + } + package { + if {$first eq "known"} { + eval _iplappend ::knownPackages $rest + } else { + # Note: require not allowed here yet... + if {!$::Nagelfar(firstpass)} { + echo "Bad type in ##nagelfar comment in db $f line $commentline" + } + } + } + option { + _ipset ::option($first) $rest + } + option+ { + eval [list _iplappend "::option($first)"] $rest + } + alias { + _ipset ::knownAliases($first) $rest + } + nspath { + eval [list _iplappend "::namespacePath($first)"] $rest + } + default { + echo "Bad type in ##nagelfar comment in db $f line $commentline" + continue + } + } + } + } + if {$addDb eq ""} { + # Clean up if we are loading all databases + set ::knownGlobals {} + set ::knownCommands {} + set ::knownPackages {} + } + + if {[_ipexists ::knownGlobals]} { + eval lappend ::knownGlobals [_ipset ::knownGlobals] + } + if {[_ipexists ::knownCommands]} { + eval [linsert [_ipset ::knownCommands] 0 lappend "::knownCommands"] + } + if {[_ipexists ::knownPackages]} { + eval lappend ::knownPackages [_ipset ::knownPackages] + } + if {[_ipexists ::dbInfo]} { + set ::Nagelfar(dbInfo) [join [_ipset ::dbInfo] \n] + } else { + set ::Nagelfar(dbInfo) {} + } + if {[_ipexists ::dbTclVersion]} { + set ::Nagelfar(dbTclVersion) [_ipset ::dbTclVersion] + } else { + set ::Nagelfar(dbTclVersion) [package present Tcl] + } + if {$addDb eq ""} { + # Clean up if we are loading all databases + catch {unset ::syntax} + catch {unset ::implicitVarNs} + catch {unset ::implicitVarCmd} + catch {unset ::return} + catch {unset ::subCmd} + catch {unset ::option} + catch {unset ::knownAliases} + catch {unset ::namespacePath} + } + if {[_iparray exists ::syntax]} { + array set ::syntax [_iparray get ::syntax] + } + if {[_iparray exists ::implicitVarNs]} { + array set ::implicitVarNs [_iparray get ::implicitVarNs] + } + if {[_iparray exists ::implicitVarCmd]} { + array set ::implicitVarCmd [_iparray get ::implicitVarCmd] + } + if {[_iparray exists ::return]} { + array set ::return [_iparray get ::return] + } + if {[_iparray exists ::subCmd]} { + array set ::subCmd [_iparray get ::subCmd] + } + if {[_iparray exists ::option]} { + array set ::option [_iparray get ::option] + } + if {[_iparray exists ::knownAliases]} { + array set ::knownAliases [_iparray get ::knownAliases] + } + if {[_iparray exists ::namespacePath]} { + array set ::knownAliases [_iparray get ::namespacePath] + } + + interp delete loadinterp + + if {$::Prefs(strictAppend)} { + set ::syntax(lappend) [string map {n v} $::syntax(lappend)] + set ::syntax(append) [string map {n v} $::syntax(append)] + } +} + +# Look for a database file for a package and load it if found. +# This is called when a package require is detected +proc lookForPackageDb {pName i} { + if {[lsearch -exact $::knownPackages $pName] >= 0} { + #errorMsg N "Seeing known package $pName" $i + return + } + set fileName [string tolower [string map ":: _" $pName]]db.tcl + set found 0 + foreach db $::Nagelfar(allDb) { + if {$fileName eq $db || $fileName eq [file tail $db]} { + loadDatabases $db + #errorMsg N "Loaded db for package $pName" $i + set found 1 + break + } + } + if {$found} { + # Double check if it is marked as known + if {[lsearch -exact $::knownPackages $pName] < 0} { + lappend ::knownPackages $pName + if {$::Nagelfar(pkgpicky)} { + errorMsg N "Package database for '$pName' not marked as known" \ + $i + } + } + } else { + if {$::Nagelfar(pkgpicky)} { + errorMsg N "No info on package '$pName' found" $i + } + } +} + +# Execute the checks +proc doCheck {} { + set intDb [info exists ::Nagelfar(dbContents)] + if {!$intDb && [llength $::Nagelfar(db)] == 0} { + if {$::Nagelfar(gui)} { + tk_messageBox -title "Nagelfar Error" -type ok -icon error \ + -message "No syntax database file selected" + return + } else { + puts stderr "No syntax database file found" + exit 3 + } + } + + set int [info exists ::Nagelfar(scriptContents)] + + if {!$int && [llength $::Nagelfar(files)] == 0} { + errEcho "No files to check" + return + } + + if {$::Nagelfar(gui)} { + allowStop + busyCursor + } + + if {!$int} { + set ::Nagelfar(editFile) "" + } + if {[info exists ::Nagelfar(resultWin)]} { + $::Nagelfar(resultWin) configure -state normal + $::Nagelfar(resultWin) delete 1.0 end + } + set ::Nagelfar(messageCnt) 0 + + # Load syntax databases + loadDatabases + + # In header generation, store info before reading + if {$::Nagelfar(header) ne ""} { + array set h_oldsyntax [array get ::syntax] + array set h_oldsubCmd [array get ::subCmd] + array set h_oldoption [array get ::option] + array set h_oldreturn [array get ::return] + array set h_oldimplicitvarns [array get ::implicitVarNs] + array set h_oldimplicitvarcmd [array get ::implicitVarCmd] + array set h_oldaliases [array get ::knownAliases] + array set h_oldnspath [array get ::namespacePath] + set h_oldknownpackages $::knownPackages + } + + # Initialise variables + set ::Nagelfar(namespaces) {} + set ::Nagelfar(procs) {} + set ::Nagelfar(object) "" + + # Do the checking + + set ::currentFile "" + set ::Nagelfar(exitstatus) 0 + if {$int} { + initMsg + parseScript $::Nagelfar(scriptContents) + flushMsg + } else { + foreach f $::Nagelfar(files) { + if {$::Nagelfar(stop)} break + if {$::Nagelfar(gui) || [llength $::Nagelfar(files)] > 1 || \ + $::Prefs(prefixFile)} { + set ::currentFile $f + } + set syntaxfile epolicy_no_socket.syntax + if {[file exists $syntaxfile]} { + if {!$::Nagelfar(quiet)} { + echo "Parsing file $syntaxfile" 1 + } + parseFile $syntaxfile + } + if {$f == $syntaxfile} continue + if {[file isfile $f] && [file readable $f]} { + if {!$::Nagelfar(quiet)} { + echo "Checking file $f" 1 + } + parseFile $f + } else { + errEcho "Could not find file '$f'" + } + } + } + # Generate header + if {$::Nagelfar(header) ne ""} { + # Exclude everything that was there from the syntax database + foreach item [array names h_oldsyntax] { + if {$h_oldsyntax($item) eq $::syntax($item)} { + unset ::syntax($item) + } + } + foreach item [array names h_oldsubCmd] { + if {$h_oldsubCmd($item) eq $::subCmd($item)} { + unset ::subCmd($item) + } + } + foreach item [array names h_oldoption] { + if {$h_oldoption($item) eq $::option($item)} { + unset ::option($item) + } + } + foreach item [array names h_oldreturn] { + if {$h_oldreturn($item) eq $::return($item)} { + unset ::return($item) + } + } + foreach item [array names h_oldimplicitvarns] { + if {$h_oldimplicitvarns($item) eq $::implicitVarNs($item)} { + unset ::implicitVarNs($item) + } + } + foreach item [array names h_oldimplicitvarcmd] { + if {$h_oldimplicitvarcmd($item) eq $::implicitVarCmd($item)} { + unset ::implicitVarCmd($item) + } + } + foreach item [array names h_oldaliases] { + if {$h_oldaliases($item) eq $::knownAliases($item)} { + unset ::knownAliases($item) + } + } + foreach item [array names h_oldnspath] { + if {$h_oldnspath($item) eq $::namespacePath($item)} { + unset ::namespacePath($item) + } + } + + if {[catch {set ch [open $::Nagelfar(header) w]}]} { + puts stderr "Could not create file \"$::Nagelfar(header)\"" + } else { + echo "Writing \"$::Nagelfar(header)\"" 1 + foreach item $::knownPackages { + if {[lsearch -exact $h_oldknownpackages $item] < 0} { + # TODO: Exclude autoloaded package info from header + # file and emit package require instead. + puts $ch "\#\#nagelfar [list package known $item]" + } + } + foreach item [lsort -dictionary [array names ::syntax]] { + puts $ch "\#\#nagelfar [list syntax $item] $::syntax($item)" + } + foreach item [lsort -dictionary [array names ::subCmd]] { + puts $ch "\#\#nagelfar [list subcmd $item] $::subCmd($item)" + } + foreach item [lsort -dictionary [array names ::option]] { + puts $ch "\#\#nagelfar [list option $item] $::option($item)" + } + foreach item [lsort -dictionary [array names ::return]] { + puts $ch "\#\#nagelfar [list return $item] $::return($item)" + } + foreach item [lsort -dictionary [array names ::implicitVarNs]] { + puts $ch "\#\#nagelfar [list implicitvarns $item] $::implicitVarNs($item)" + } + foreach item [lsort -dictionary [array names ::implicitVarCmd]] { + puts $ch "\#\#nagelfar [list implicitvarcmd $item] $::implicitVarCmd($item)" + } + foreach item [lsort -dictionary [array names ::knownAliases]] { + puts $ch "\#\#nagelfar [list alias $item] $::knownAliases($item)" + } + foreach item [lsort -dictionary [array names ::namespacePath]] { + puts $ch "\#\#nagelfar [list nspath $item] $::namespacePath($item)" + } + pluginHandleWriteHeader $ch + close $ch + } + } + initMsg + finalizePlugin + flushMsg + if {$::Nagelfar(gui)} { + if {[info exists ::Nagelfar(resultWin)]} { + set result [$::Nagelfar(resultWin) get 1.0 end-1c] + set n [regsub -all {Line\s+\d+: N } $result "" ->] + set w [regsub -all {Line\s+\d+: W } $result "" ->] + set e [regsub -all {Line\s+\d+: E } $result "" ->] + # show statistics depending on severity level + switch $::Prefs(severity) { + N {echo "Done (E/W/N: $e/$w/$n)" 1} + W {echo "Done (E/W: $e/$w)" 1} + E {echo "Done (E: $e)" 1} + } + } else { + echo "Done" 1 + } + normalCursor + progressUpdate -1 + } +} +#---------------------------------------------------------------------- +# Nagelfar, a syntax checker for Tcl. +# Copyright (c) 1999-2007, Peter Spjuth +# +# This program is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 2 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program; see the file COPYING. If not, write to +# the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +# Boston, MA 02111-1307, USA. +# +#---------------------------------------------------------------------- +# gui.tcl +#---------------------------------------------------------------------- + +##nagelfar variable ::Nagelfar(resultWin) _obj,text + +proc busyCursor {} { + if {![info exists ::oldcursor]} { + set ::oldcursor [. cget -cursor] + set ::oldcursor2 [$::Nagelfar(resultWin) cget -cursor] + } + + . config -cursor watch + $::Nagelfar(resultWin) configure -cursor watch +} + +proc normalCursor {} { + . config -cursor $::oldcursor + $::Nagelfar(resultWin) configure -cursor $::oldcursor2 +} + +proc exitApp {} { + exit +} + +# Browse for and add a syntax database file +proc addDbFile {} { + if {[info exists ::Nagelfar(lastdbdir)]} { + set initdir $::Nagelfar(lastdbdir) + } elseif {[info exists ::Nagelfar(lastdir)]} { + set initdir $::Nagelfar(lastdir) + } else { + set initdir [pwd] + } + set apa [tk_getOpenFile -title "Select db file" \ + -initialdir $initdir] + if {$apa == ""} return + + lappend ::Nagelfar(db) $apa + lappend ::Nagelfar(allDb) $apa + lappend ::Nagelfar(allDbView) $apa + updateDbSelection -fromvar + set ::Nagelfar(lastdbdir) [file dirname $apa] +} + +# File drop using TkDnd +proc fileDropDb {files} { + foreach file $files { + set file [fileRelative [pwd] $file] + lappend ::Nagelfar(db) $file + lappend ::Nagelfar(allDb) $file + lappend ::Nagelfar(allDbView) $file + } + updateDbSelection -fromvar +} + +# Remove a file from the database list +proc removeDbFile {} { + set ixs [lsort -decreasing -integer [$::Nagelfar(dbWin) curselection]] + foreach ix $ixs { + set ::Nagelfar(allDb) [lreplace $::Nagelfar(allDb) $ix $ix] + set ::Nagelfar(allDbView) [lreplace $::Nagelfar(allDbView) $ix $ix] + } + updateDbSelection + updateDbSelection -fromvar +} + +# Browse for and add a file to check. +proc addFile {} { + if {[info exists ::Nagelfar(lastdir)]} { + set initdir $::Nagelfar(lastdir) + } elseif {[info exists ::Nagelfar(lastdbdir)]} { + set initdir $::Nagelfar(lastdbdir) + } else { + set initdir [pwd] + } + + set filetypes [list {{Tcl Files} {.tcl}} \ + [list {All Tcl Files} $::Prefs(extensions)] \ + {{All Files} {*}}] + set apa [tk_getOpenFile -title "Select file(s) to check" \ + -initialdir $initdir \ + -multiple 1 \ + -filetypes $filetypes] + if {[llength $apa] == 0} return + + set newpwd [file dirname [lindex $apa 0]] + if {[llength $::Nagelfar(files)] == 0 && $newpwd ne [pwd]} { + set res [tk_messageBox -title "Nagelfar" -icon question -type yesno \ + -message \ + "Change current directory to [file nativename $newpwd] ?"] + if {$res eq "yes"} { + cd $newpwd + } + } + set skipped {} + foreach file $apa { + set relfile [fileRelative [pwd] $file] + if {[lsearch -exact $::Nagelfar(files) $relfile] >= 0} { + lappend skipped $relfile + continue + } + lappend ::Nagelfar(files) $relfile + set ::Nagelfar(lastdir) [file dirname $file] + } + if {[llength $skipped] > 0} { + tk_messageBox -title "Nagelfar" -icon info -type ok -message \ + "Skipped duplicate file" + } +} + +# Remove a file from the list to check +proc removeFile {} { + set ixs [lsort -decreasing -integer [$::Nagelfar(fileWin) curselection]] + foreach ix $ixs { + set ::Nagelfar(files) [lreplace $::Nagelfar(files) $ix $ix] + } +} + +# Move a file up/down file list +proc moveFile {dir} { + # FIXA: Allow this line on a global level or in .syntax file + ##nagelfar variable ::Nagelfar(fileWin) _obj,listbox + set ix [lindex [$::Nagelfar(fileWin) curselection] 0] + if {$ix eq ""} return + set len [llength $::Nagelfar(files)] + set nix [expr {$ix + $dir}] + if {$nix < 0 || $nix >= $len} return + set item [lindex $::Nagelfar(files) $ix] + set ::Nagelfar(files) [lreplace $::Nagelfar(files) $ix $ix] + set ::Nagelfar(files) [linsert $::Nagelfar(files) $nix $item] + $::Nagelfar(fileWin) see $nix + $::Nagelfar(fileWin) selection clear 0 end + $::Nagelfar(fileWin) selection set $nix + $::Nagelfar(fileWin) selection anchor $nix + $::Nagelfar(fileWin) activate $nix +} + +# File drop using TkDnd +proc fileDropFile {files} { + foreach file $files { + lappend ::Nagelfar(files) [fileRelative [pwd] $file] + } +} +# This shows the file and the line from an error in the result window. +proc showError {{lineNo {}}} { + set w $::Nagelfar(resultWin) + if {$lineNo == ""} { + set lineNo [lindex [split [$w index current] .] 0] + } + + $w tag remove hl 1.0 end + $w tag add hl $lineNo.0 $lineNo.end + $w mark set insert $lineNo.0 + set line [$w get $lineNo.0 $lineNo.end] + + if {[regexp {^(.*): Line\s+(\d+):} $line -> fileName fileLine]} { + editFile $fileName $fileLine + } elseif {[regexp {^Line\s+(\d+):} $line -> fileLine]} { + editFile "" $fileLine + } +} + +# Scroll a text window to view a certain line, and possibly some +# lines before and after. +proc seeText {w si} { + $w see $si + $w see $si-3lines + $w see $si+3lines + if {[llength [$w bbox $si]] == 0} { + $w yview $si-3lines + } + if {[llength [$w bbox $si]] == 0} { + $w yview $si + } +} + +# Make next "E" error visible +proc seeNextError {} { + set w $::Nagelfar(resultWin) + set lineNo [lindex [split [$w index insert] .] 0] + + set index [$w search -exact ": E " $lineNo.end] + if {$index eq ""} { + $w see end + return + } + seeText $w $index + set lineNo [lindex [split $index .] 0] + $w tag remove hl 1.0 end + $w tag add hl $lineNo.0 $lineNo.end + $w mark set insert $lineNo.0 +} + +proc resultPopup {x y X Y} { + set w $::Nagelfar(resultWin) + + set index [$w index @$x,$y] + set tags [$w tag names $index] + set tag [lsearch -glob -inline $tags "message*"] + if {$tag == ""} { + set lineNo [lindex [split $index .] 0] + set line [$w get $lineNo.0 $lineNo.end] + } else { + set range [$w tag nextrange $tag 1.0] + set line [lindex [split [eval \$w get $range] \n] 0] + } + + destroy .popup + menu .popup + + if {[regexp {^(.*): Line\s+(\d+):} $line -> fileName fileLine]} { + .popup add command -label "Show File" \ + -command [list editFile $fileName $fileLine] + } + if {[regexp {^(.*): Line\s+\d+:\s*(.*)$} $line -> pre post]} { + .popup add command -label "Filter this message" \ + -command [list addFilter "*$pre*$post*" -1 -1 1] + .popup add command -label "Filter this message in all files" \ + -command [list addFilter "*$post*" -1 -1 1] + regsub {".+?"} $post {"*"} post2 + regsub -all {\d+} $post2 "*" post2 + if {$post2 ne $post} { + .popup add command -label "Filter this generic message" \ + -command [list addFilter "*$post2*" -1 -1 1] + } + } + # FIXA: This should be handled abit better. + .popup add command -label "Reset all filters" -command resetFilters + + if {[$::Nagelfar(resultWin) get 1.0 1.end] ne ""} { + .popup add command -label "Save Result" -command saveResult + } + + tk_popup .popup $X $Y +} + +# Save result as file +proc saveResult {} { + # set initial filename to 1st file in list + set iniFile [file rootname [lindex $::Nagelfar(files) 0]] + if {$iniFile == ""} { + set iniFile "noname" + } + append iniFile ".nfr" + set iniDir [file dirname $iniFile] + set types { + {"Nagelfar Result" {.nfr}} + {"All Files" {*}} + } + set file [tk_getSaveFile -initialdir $iniDir -initialfile $iniFile \ + -filetypes $types -title "Save File"] + if {$file != ""} { + set ret [catch {open $file w} msg] + if {!$ret} { + set fid $msg + fconfigure $fid -translation {auto lf} + set ret [catch {puts $fid [$::Nagelfar(resultWin) get 1.0 end-1c]} msg] + } + catch {close $fid} + if {!$ret} { + tk_messageBox -title "Nagelfar" -icon info -type ok \ + -message "Result saved as [file nativename $file]" + } else { + tk_messageBox -title "Nagelfar Error" -type ok -icon error \ + -message "Cannot write [file nativename $file]:\n$msg" + } + } +} + +# Update the selection in the db listbox to or from the db list. +proc updateDbSelection {{fromVar -fromgui}} { + if {$fromVar eq "-fromvar"} { + $::Nagelfar(dbWin) selection clear 0 end + # Try to keep one selected + if {[llength $::Nagelfar(db)] == 0} { + set ::Nagelfar(db) [lrange $::Nagelfar(allDb) 0 0] + } + foreach f $::Nagelfar(db) { + set i [lsearch $::Nagelfar(allDb) $f] + if {$i >= 0} { + $::Nagelfar(dbWin) selection set $i + } + } + return + } + + set ::Nagelfar(db) {} + foreach ix [$::Nagelfar(dbWin) curselection] { + lappend ::Nagelfar(db) [lindex $::Nagelfar(allDb) $ix] + } +} + +# A little helper to make a scrolled window +# It returns the name of the scrolled window +##nagelfar syntax Scroll x x x p* +##nagelfar option Scroll -listvariable -height -width -selectmode -wrap -font -linemap +##nagelfar option Scroll\ -listvariable v +proc Scroll {dir class w args} { + switch -- $dir { + both { + set scrollx 1 + set scrolly 1 + } + x { + set scrollx 1 + set scrolly 0 + } + y { + set scrollx 0 + set scrolly 1 + } + default { + return -code error "Bad scrolldirection \"$dir\"" + } + } + + frame $w + eval [list $class $w.s] $args + + # Move border properties to frame + set bw [$w.s cget -borderwidth] + set relief [$w.s cget -relief] + $w configure -relief $relief -borderwidth $bw + $w.s configure -borderwidth 0 + + grid $w.s -sticky news + + if {$scrollx} { + $w.s configure -xscrollcommand [list $w.sbx set] + scrollbar $w.sbx -orient horizontal -command [list $w.s xview] + grid $w.sbx -row 1 -sticky we + } + if {$scrolly} { + $w.s configure -yscrollcommand [list $w.sby set] + scrollbar $w.sby -orient vertical -command [list $w.s yview] + grid $w.sby -row 0 -column 1 -sticky ns + } + grid columnconfigure $w 0 -weight 1 + grid rowconfigure $w 0 -weight 1 + + return $w.s +} + +# Set the progress +proc progressUpdate {n} { + if {$n < 0} { + $::Nagelfar(progressWin) configure -relief flat + } else { + $::Nagelfar(progressWin) configure -relief solid + } + if {$n <= 0} { + place $::Nagelfar(progressWin).f -x -100 -relx 0 -y 0 -rely 0 \ + -relheight 1.0 -relwidth 0.0 + } else { + set frac [expr {double($n) / $::Nagelfar(progressMax)}] + + place $::Nagelfar(progressWin).f -x 0 -relx 0 -y 0 -rely 0 \ + -relheight 1.0 -relwidth $frac + } + update idletasks +} + +# Set the 100 % level of the progress bar +proc progressMax {n} { + set ::Nagelfar(progressMax) $n + progressUpdate 0 +} + +# Create a simple progress bar +proc progressBar {w} { + set ::Nagelfar(progressWin) $w + + frame $w -bd 1 -relief solid -padx 2 -pady 2 -width 100 -height 20 + frame $w.f -background blue + + progressMax 100 + progressUpdate -1 +} + +# A thing to easily get to debug mode +proc backDoor {a} { + append ::Nagelfar(backdoor) $a + set ::Nagelfar(backdoor) [string range $::Nagelfar(backdoor) end-9 end] + if {$::Nagelfar(backdoor) eq "PeterDebug"} { + # Second time it redraw window, thus giving debug menu + if {$::debug == 1} { + makeWin + } + set ::debug 1 + catch {console show} + set ::Nagelfar(backdoor) "" + } +} + +# Flag that the current run should be stopped +proc stopCheck {} { + set ::Nagelfar(stop) 1 + $::Nagelfar(stopWin) configure -state disabled +} + +# Allow the stop button to be pressed +proc allowStop {} { + set ::Nagelfar(stop) 0 + $::Nagelfar(stopWin) configure -state normal +} + +# Create main window +proc makeWin {} { + defaultGuiOptions + + catch {font create ResultFont -family courier \ + -size [lindex $::Prefs(resultFont) 1]} + + eval destroy [winfo children .] + wm protocol . WM_DELETE_WINDOW exitApp + wm title . "Nagelfar: Tcl Syntax Checker" + tk appname Nagelfar + wm withdraw . + + # Syntax database section + + frame .fs + label .fs.l -text "Syntax database files" + button .fs.bd -text "Del" -width 10 -command removeDbFile + button .fs.b -text "Add" -width 10 -command addDbFile + set lb [Scroll y listbox .fs.lb \ + -listvariable ::Nagelfar(allDbView) \ + -height 4 -width 40 -selectmode extended] + set ::Nagelfar(dbWin) $lb + + bind $lb "removeDbFile" + bind $lb <> updateDbSelection + bind $lb [list focus $lb] + updateDbSelection -fromvar + + grid .fs.l .fs.bd .fs.b -sticky w -padx 2 -pady 2 + grid .fs.lb - - -sticky news + grid columnconfigure .fs 0 -weight 1 + grid rowconfigure .fs 1 -weight 1 + + + # File section + + frame .ff + label .ff.l -text "Tcl files to check" + button .ff.bd -text "Del" -width 10 -command removeFile + button .ff.b -text "Add" -width 10 -command addFile + set lb [Scroll y listbox .ff.lb \ + -listvariable ::Nagelfar(files) \ + -height 4 -width 40] + set ::Nagelfar(fileWin) $lb + + bind $lb "removeFile" + bind $lb [list focus $lb] + bind $lb {moveFile -1} + bind $lb {moveFile 1} + + grid .ff.l .ff.bd .ff.b -sticky w -padx 2 -pady 2 + grid .ff.lb - - -sticky news + grid columnconfigure .ff 0 -weight 1 + grid rowconfigure .ff 1 -weight 1 + + # Set up file dropping in listboxes if TkDnd is available + if {![catch {package require tkdnd}]} { + dnd bindtarget . text/uri-list {fileDropFile %D} + #dnd bindtarget $::Nagelfar(fileWin) text/uri-list {fileDropFile %D} + dnd bindtarget $::Nagelfar(dbWin) text/uri-list {fileDropDb %D} + } + + # Result section + + frame .fr + progressBar .fr.pr + button .fr.b -text "Check" -underline 0 -width 10 -command "doCheck" + bind . doCheck + bind . doCheck + button .fr.bb -text "Stop" -underline 0 -width 10 -command "stopCheck" + bind . stopCheck + bind . stopCheck + set ::Nagelfar(stopWin) .fr.bb + button .fr.bn -text "Next E" -underline 0 -width 10 -command "seeNextError" + bind . seeNextError + bind . seeNextError + if {$::debug == 0} { + bind . "backDoor %A" + } + + set ::Nagelfar(resultWin) [Scroll both \ + text .fr.t -width 100 -height 25 -wrap none -font ResultFont] + + grid .fr.b .fr.bb .fr.bn .fr.pr -sticky w -padx 2 -pady {0 2} + grid .fr.t - - - -sticky news + grid columnconfigure .fr 2 -weight 1 + grid rowconfigure .fr 1 -weight 1 + + $::Nagelfar(resultWin) tag configure info -foreground #707070 + $::Nagelfar(resultWin) tag configure error -foreground red + $::Nagelfar(resultWin) tag configure hl -background yellow + bind $::Nagelfar(resultWin) "showError ; break" + bind $::Nagelfar(resultWin) "resultPopup %x %y %X %Y ; break" + + # Use the panedwindow in 8.4 + panedwindow .pw -orient vertical + lower .pw + frame .pw.f + grid .fs x .ff -in .pw.f -sticky news + grid columnconfigure .pw.f {0 2} -weight 1 -uniform a + grid columnconfigure .pw.f 1 -minsize 4 + grid rowconfigure .pw.f 0 -weight 1 + + # Make sure the frames have calculated their size before + # adding them to the pane + # This update can be excluded in 8.4.4+ + update idletasks + .pw add .pw.f -sticky news + .pw add .fr -sticky news + pack .pw -fill both -expand 1 + + + # Menus + + menu .m + . configure -menu .m + + # File menu + + .m add cascade -label "File" -underline 0 -menu .m.mf + menu .m.mf + .m.mf add command -label "Exit" -underline 1 -command exitApp + + # Options menu + addOptionsMenu .m + + # Tools menu + + .m add cascade -label "Tools" -underline 0 -menu .m.mt + menu .m.mt + .m.mt add command -label "Edit Window" -underline 0 \ + -command {editFile "" 0} + .m.mt add command -label "Browse Database" -underline 0 \ + -command makeDbBrowserWin + addRegistryToMenu .m.mt + + # Debug menu + + if {$::debug == 1} { + .m add cascade -label "Debug" -underline 0 -menu .m.md + menu .m.md + if {$::tcl_platform(platform) == "windows"} { + .m.md add checkbutton -label Console -variable consolestate \ + -onvalue show -offvalue hide \ + -command {console $consolestate} + .m.md add separator + } + .m.md add command -label "Reread Source" -command {source $thisScript} + .m.md add separator + .m.md add command -label "Redraw Window" -command {makeWin} + #.m.md add separator + #.m.md add command -label "Normal Cursor" -command {normalCursor} + } + + # Help menu is last + + .m add cascade -label "Help" -underline 0 -menu .m.help + menu .m.help + foreach label {README Messages {Syntax Databases} {Inline Comments} {Call By Name} {Syntax Tokens} {Code Coverage} {Plugins} {Object Orientation}} \ + file {README.txt messages.txt syntaxdatabases.txt inlinecomments.txt call-by-name.txt syntaxtokens.txt codecoverage.txt plugins.txt oo.txt} { + .m.help add command -label $label -command [list makeDocWin $file] + } + .m.help add separator + .m.help add command -label About -command makeAboutWin + + wm deiconify . +} + +############################# +# A simple file viewer/editor +############################# + +# Try to locate emacs, if not done before +proc locateEmacs {} { + if {[info exists ::Nagelfar(emacs)]} return + + # Look for standard names in the path + set path [auto_execok emacs] + if {$path != ""} { + set ::Nagelfar(emacs) [list $path -f server-start] + } else { + set path [auto_execok runemacs.exe] + if {$path != ""} { + set ::Nagelfar(emacs) [list $path] + } + } + + if {![info exists ::Nagelfar(emacs)]} { + # Try the places where I usually have emacs on Windows + foreach dir [lsort -decreasing -dictionary \ + [glob -nocomplain c:/apps/emacs*]] { + set em [file join $dir bin runemacs.exe] + set em [file normalize $em] + if {[file exists $em]} { + set ::Nagelfar(emacs) [list $em] + break + } + } + } + # Look for emacsclient + foreach name {emacsclient} { + set path [auto_execok $name] + if {$path != ""} { + set ::Nagelfar(emacsclient) $path + break + } + } +} + +# Try to show a file using emacs +proc tryEmacs {filename lineNo} { + locateEmacs + # First try with emacsclient + if {[catch {exec $::Nagelfar(emacsclient) -n +$lineNo $filename}]} { + # Start a new emacs + if {[catch {eval exec $::Nagelfar(emacs) [list +$lineNo \ + $filename] &}]} { + # Failed + return 0 + } + } + return 1 +} + +# Try to show a file using vim +proc tryVim {filename lineNo} { + if {[catch {exec gvim +$lineNo $filename &}]} { + if {[catch {exec xterm -exec vi +$lineNo $filename &}]} { + return 0 + } + } + return 1 +} + +# Try to show a file using pfe +proc tryPfe {filename lineNo} { + if {$lineNo > 0} { + if {[catch {exec [auto_execok pfe32] /g $lineNo $filename &}]} { + return 0 + } + } elseif {[catch {exec [auto_execok pfe32] &}]} { + return 0 + } + return 1 +} + +# Edit a file using internal or external editor. +proc editFile {filename lineNo} { + if {$::Prefs(editor) eq "emacs" && [tryEmacs $filename $lineNo]} return + if {$::Prefs(editor) eq "vim" && [tryVim $filename $lineNo]} return + if {$::Prefs(editor) eq "pfe" && [tryPfe $filename $lineNo]} return + + if {[winfo exists .fv]} { + wm deiconify .fv + raise .fv + set w $::Nagelfar(editWin) + } else { + toplevel .fv + wm title .fv "Nagelfar Editor" + + if {$::Nagelfar(withCtext)} { + set w [Scroll both ctext .fv.t -linemap 0 \ + -width 80 -height 25 -font $::Prefs(editFileFont)] + ctext::setHighlightTcl $w + } else { + set w [Scroll both text .fv.t \ + -width 80 -height 25 -font $::Prefs(editFileFont)] + } + set ::Nagelfar(editWin) $w + # Set up a tag for incremental search bindings + if {[info procs textSearch::enableSearch] != ""} { + textSearch::enableSearch $w -label ::Nagelfar(iSearch) + } + + frame .fv.f + grid .fv.t -sticky news + grid .fv.f -sticky we + grid columnconfigure .fv 0 -weight 1 + grid rowconfigure .fv 0 -weight 1 + + menu .fv.m + .fv configure -menu .fv.m + .fv.m add cascade -label "File" -underline 0 -menu .fv.m.mf + menu .fv.m.mf + .fv.m.mf add command -label "Save" -underline 0 -command "saveFile" + .fv.m.mf add separator + .fv.m.mf add command -label "Close" -underline 0 -command "closeFile" + + .fv.m add cascade -label "Edit" -underline 0 -menu .fv.m.me + menu .fv.m.me + .fv.m.me add command -label "Clear/Paste" -underline 6 \ + -command "clearAndPaste" + .fv.m.me add command -label "Check" -underline 0 \ + -command "checkEditWin" + + .fv.m add cascade -label "Search" -underline 0 -menu .fv.m.ms + menu .fv.m.ms + if {[info procs textSearch::searchMenu] != ""} { + textSearch::searchMenu .fv.m.ms + } else { + .fv.m.ms add command -label "Text search not available" \ + -state disabled + } + + .fv.m add cascade -label "Options" -underline 0 -menu .fv.m.mo + menu .fv.m.mo + .fv.m.mo add checkbutton -label "Backup" -underline 0 \ + -variable ::Prefs(editFileBackup) + + .fv.m.mo add cascade -label "Font" -underline 0 -menu .fv.m.mo.mf + menu .fv.m.mo.mf + set cmd "[list $w] configure -font \$::Prefs(editFileFont)" + foreach lab {Small Medium Large} size {8 10 14} { + .fv.m.mo.mf add radiobutton -label $lab -underline 0 \ + -variable ::Prefs(editFileFont) \ + -value [list Courier $size] \ + -command $cmd + } + + label .fv.f.ln -width 5 -anchor e -textvariable ::Nagelfar(lineNo) + label .fv.f.li -width 1 -pady 0 -padx 0 \ + -textvariable ::Nagelfar(iSearch) + pack .fv.f.ln .fv.f.li -side right -padx 3 + + bind $w { + after idle { + set ::Nagelfar(lineNo) \ + [lindex [split [$::Nagelfar(editWin) index insert] .] 0] + } + } + bind $w [bind $w ] + + wm protocol .fv WM_DELETE_WINDOW closeFile + $w tag configure hl -background yellow + if {[info exists ::Nagelfar(editFileGeom)]} { + wm geometry .fv $::Nagelfar(editFileGeom) + } else { + after idle {after 1 { + set ::Nagelfar(editFileOrigGeom) [wm geometry .fv] + }} + } + } + + if {$filename != "" && \ + (![info exists ::Nagelfar(editFile)] || \ + $filename != $::Nagelfar(editFile))} { + $w delete 1.0 end + set ::Nagelfar(editFile) $filename + wm title .fv [file tail $filename] + + # Try to figure out eol style + set ch [open $filename r] + fconfigure $ch -translation binary + set data [read $ch 400] + close $ch + + set crCnt [expr {[llength [split $data \r]] - 1}] + set lfCnt [expr {[llength [split $data \n]] - 1}] + if {$crCnt == 0 && $lfCnt > 0} { + set ::Nagelfar(editFileTranslation) lf + } elseif {$crCnt > 0 && $crCnt == $lfCnt} { + set ::Nagelfar(editFileTranslation) crlf + } elseif {$lfCnt == 0 && $crCnt > 0} { + set ::Nagelfar(editFileTranslation) cr + } else { + set ::Nagelfar(editFileTranslation) auto + } + + #puts "EOL $::Nagelfar(editFileTranslation)" + + set ch [open $filename r] + set data [read $ch] + close $ch + if {$::Nagelfar(withCtext)} { + $w fastinsert end $data + } else { + $w insert end $data + } + } + # Disable Save if there is no file + if {![info exists ::Nagelfar(editFile)] || $::Nagelfar(editFile) eq ""} { + .fv.m.mf entryconfigure "Save" -state disabled + } else { + .fv.m.mf entryconfigure "Save" -state normal + } + + $w tag remove hl 1.0 end + $w tag add hl $lineNo.0 $lineNo.end + $w mark set insert $lineNo.0 + focus $w + set ::Nagelfar(lineNo) $lineNo + update + $w see insert + #after 1 {after idle {$::Nagelfar(editWin) see insert}} + if {$::Nagelfar(withCtext)} { + after idle [list $w highlight 1.0 end] + } +} + +proc saveFile {} { + if {![info exists ::Nagelfar(editFile)]} { + # Gracefully handle if this happens + return + } + if {[tk_messageBox -parent .fv -title "Save File" -type okcancel \ + -icon question \ + -message "Save file\n$::Nagelfar(editFile)"] != "ok"} { + return + } + if {$::Prefs(editFileBackup)} { + file copy -force -- $::Nagelfar(editFile) $::Nagelfar(editFile)~ + } + set ch [open $::Nagelfar(editFile) w] + fconfigure $ch -translation $::Nagelfar(editFileTranslation) + puts -nonewline $ch [$::Nagelfar(editWin) get 1.0 end-1char] + close $ch +} + +proc closeFile {} { + if {[info exists ::Nagelfar(editFileGeom)] || \ + ([info exists ::Nagelfar(editFileOrigGeom)] && \ + $::Nagelfar(editFileOrigGeom) != [wm geometry .fv])} { + set ::Nagelfar(editFileGeom) [wm geometry .fv] + } + + destroy .fv + set ::Nagelfar(editFile) "" +} + +proc clearAndPaste {} { + set w $::Nagelfar(editWin) + $w delete 1.0 end + focus $w + + if {$::tcl_platform(platform) == "windows"} { + event generate $w <> + } else { + $w insert 1.0 [selection get] + } +} + +proc checkEditWin {} { + set w $::Nagelfar(editWin) + + set script [$w get 1.0 end] + set ::Nagelfar(scriptContents) $script + doCheck + unset ::Nagelfar(scriptContents) +} + +###### +# Help +###### + +proc helpWin {w title} { + destroy $w + + toplevel $w + wm title $w $title + bind $w "destroy $w" + bind $w "destroy $w" + frame $w.f + button $w.b -text "Close" -command "destroy $w" -width 10 \ + -default active + pack $w.b -side bottom -pady 3 + pack $w.f -side top -expand y -fill both + focus $w + return $w.f +} + +proc makeAboutWin {} { + global version + + set w [helpWin .ab "About Nagelfar"] + + + text $w.t -width 45 -height 7 -wrap none -relief flat \ + -bg [$w cget -bg] + pack $w.t -side top -expand y -fill both + + $w.t insert end "A syntax checker for Tcl\n\n" + $w.t insert end "$version\n\n" + $w.t insert end "Made by Peter Spjuth\n" + $w.t insert end "E-Mail: peter.spjuth@gmail.com\n" + $w.t insert end "\nURL: http://nagelfar.berlios.de\n" + $w.t insert end "\nTcl version: [info patchlevel]" + set d [package provide tkdnd] + if {$d != ""} { + $w.t insert end "\nTkDnd version: $d" + } + catch {loadDatabases} + if {[info exists ::Nagelfar(dbInfo)] && $::Nagelfar(dbInfo) != ""} { + $w.t insert end "\nSyntax database: $::Nagelfar(dbInfo)" + } + set last [lindex [split [$w.t index end] "."] 0] + $w.t configure -height $last + $w.t configure -state disabled +} + +# Partial backslash-subst +proc mySubst {str} { + subst -nocommands -novariables [string map {\\\n \\\\\n} $str] +} + +# Insert a text file into a text widget. +# Any XML-style tags in the file are used as tags in the text window. +proc insertTaggedText {w file} { + set ch [open $file r] + set data [read $ch] + close $ch + + # Disable tag handling since current doc files are just text + $w insert end $data + return + + set tags {} + while {$data != ""} { + if {[regexp {^([^<]*)<(/?)([^>]+)>(.*)$} $data -> pre sl tag post]} { + $w insert end [mySubst $pre] $tags + set i [lsearch $tags $tag] + if {$sl != ""} { + # Remove tag + if {$i >= 0} { + set tags [lreplace $tags $i $i] + } + } else { + # Add tag + lappend tags $tag + } + set data $post + } else { + $w insert end [mySubst $data] $tags + set data "" + } + } +} + +proc makeDocWin {fileName} { + set w [helpWin .doc "Nagelfar Help"] + set t [Scroll both \ + text $w.t -width 80 -height 25 -wrap none -font ResultFont] + pack $w.t -side top -expand 1 -fill both + + # Set up tags + $t tag configure ul -underline 1 + $t tag configure u -underline 1 + + if {![file exists $::docDir/$fileName]} { + $t insert end "ERROR: Could not find doc file " + $t insert end \"$fileName\" + return + } + insertTaggedText $t $::docDir/$fileName + + #focus $t + $t configure -state disabled +} + +# Generate a file path relative to a dir +proc fileRelative {dir file} { + set dirpath [file split $dir] + set filepath [file split $file] + set newpath {} + + set dl [llength $dirpath] + set fl [llength $filepath] + for {set t 0} {$t < $dl && $t < $fl} {incr t} { + set f [lindex $filepath $t] + set d [lindex $dirpath $t] + if {$f ne $d} break + } + # Return file if too unequal + if {$t <= 2 || ($dl - $t) > 3} { + return $file + } + for {set u $t} {$u < $dl} {incr u} { + lappend newpath ".." + } + return [eval file join $newpath [lrange $filepath $t end]] +} + +proc defaultGuiOptions {} { + catch {package require griffin} + + option add *Menu.tearOff 0 + if {[tk windowingsystem]=="x11"} { + option add *Menu.activeBorderWidth 1 + option add *Menu.borderWidth 1 + + option add *Listbox.exportSelection 0 + option add *Listbox.borderWidth 1 + option add *Listbox.highlightThickness 1 + option add *Font "Helvetica -12" + } + + if {$::tcl_platform(platform) == "windows"} { + option add *Panedwindow.sashRelief flat + option add *Panedwindow.sashWidth 4 + option add *Panedwindow.sashPad 0 + } +} +#---------------------------------------------------------------------- +# dbbrowser.tcl, Database browser +#---------------------------------------------------------------------- + +proc makeDbBrowserWin {} { + if {[winfo exists .db]} { + wm deiconify .db + raise .db + set w $::Nagelfar(dbBrowserWin) + } else { + toplevel .db + wm title .db "Nagelfar Database" + + set w [Scroll y text .db.t -wrap word \ + -width 80 -height 15 -font $::Prefs(editFileFont)] + set ::Nagelfar(dbBrowserWin) $w + $w tag configure all -lmargin2 2c + set f [frame .db.f -padx 3 -pady 3] + grid .db.f -sticky we + grid .db.t -sticky news + grid columnconfigure .db 0 -weight 1 + grid rowconfigure .db 1 -weight 1 + + label $f.l -text "Command" + entry $f.e -textvariable ::Nagelfar(dbBrowserCommand) -width 15 + button $f.b -text "Search" -command dbBrowserSearch -default active + + grid $f.l $f.e $f.b -sticky ew -padx 3 + grid columnconfigure $f 1 -weight 1 + + bind .db dbBrowserSearch + } +} + +proc dbBrowserSearch {} { + set cmd $::Nagelfar(dbBrowserCommand) + set w $::Nagelfar(dbBrowserWin) + + loadDatabases + $w delete 1.0 end + + # Must be at least one word char in the pattern + set pat $cmd* + if {![regexp {\w} $pat]} { + set pat "" + } + + foreach item [lsort -dictionary [array names ::syntax $pat]] { + $w insert end "\#\#nagelfar syntax [list $item]" + $w insert end " " + $w insert end $::syntax($item)\n + } + foreach item [lsort -dictionary [array names ::subCmd $pat]] { + $w insert end "\#\#nagelfar subcmd [list $item]" + $w insert end " " + $w insert end $::subCmd($item)\n + } + foreach item [lsort -dictionary [array names ::option $pat]] { + $w insert end "\#\#nagelfar option [list $item]" + $w insert end " " + $w insert end $::option($item)\n + } + foreach item [lsort -dictionary [array names ::return $pat]] { + $w insert end "\#\#nagelfar return [list $item]" + $w insert end " " + $w insert end $::return($item)\n + } + + if {[$w index end] eq "2.0"} { + $w insert end "No match!" + } + $w tag add all 1.0 end +} +#---------------------------------------------------------------------- +# registry.tcl, Support for Windows Registry +#---------------------------------------------------------------------- + +# Make a labelframe for one registry item +proc makeRegistryFrame {w label key newvalue} { + + set old {} + catch {set old [registry get $key {}]} + + set l [labelframe $w -text $label -padx 4 -pady 4] + + label $l.key1 -text "Key:" + label $l.key2 -text $key + label $l.old1 -text "Old value:" + label $l.old2 -text $old + label $l.new1 -text "New value:" + label $l.new2 -text $newvalue + + button $l.change -text "Change" -width 10 -command \ + "[list registry set $key {} $newvalue] ; \ + [list $l.change configure -state disabled]" + button $l.delete -text "Delete" -width 10 -command \ + "[list registry delete $key] ; \ + [list $l.delete configure -state disabled]" + if {$newvalue eq $old} { + $l.change configure -state disabled + } + if {"" eq $old} { + $l.delete configure -state disabled + } + grid $l.key1 $l.key2 - -sticky "w" -padx 4 -pady 4 + grid $l.old1 $l.old2 - -sticky "w" -padx 4 -pady 4 + grid $l.new1 $l.new2 - -sticky "w" -padx 4 -pady 4 + grid $l.delete - $l.change -sticky "w" -padx 4 -pady 4 + grid $l.change -sticky "e" + grid columnconfigure $l 2 -weight 1 +} + +# Registry dialog +proc makeRegistryWin {} { + global thisScript + + # Locate executable for this program + set exe [info nameofexecutable] + if {[regexp {^(.*wish)\d+\.exe$} $exe -> pre]} { + set alt $pre.exe + if {[file exists $alt]} { + set a [tk_messageBox -title "Nagelfar" -icon question \ + -title "Which Wish" -message \ + "Would you prefer to use the executable\n\ + \"$alt\"\ninstead of\n\ + \"$exe\"\nin the registry settings?" -type yesno] + if {$a eq "yes"} { + set exe $alt + } + } + } + + set top .reg + destroy $top + toplevel $top + wm title $top "Register Nagelfar" + + # Registry keys + + set key {HKEY_CLASSES_ROOT\.tcl\shell\Check\command} + set old {} + catch {set old [registry get {HKEY_CLASSES_ROOT\.tcl} {}]} + if {$old != ""} { + set key "HKEY_CLASSES_ROOT\\$old\\shell\\Check\\command" + } + + # Are we in a starkit? + if {[info exists ::starkit::topdir]} { + # In a starpack ? + set exe [file normalize $exe] + if {[file normalize $::starkit::topdir] eq $exe} { + set myexe [list $exe] + } else { + set myexe [list $exe $::starkit::topdir] + } + } else { + if {[regexp {wish\d+\.exe} $exe]} { + set exe [file join [file dirname $exe] wish.exe] + if {[file exists $exe]} { + set myexe [list $exe] + } + } + set myexe [list $exe $thisScript] + } + + set valbase {} + foreach item $myexe { + lappend valbase \"[file nativename $item]\" + } + set valbase [join $valbase] + + set new "$valbase -gui \"%1\"" + makeRegistryFrame $top.d "Check" $key $new + + pack $top.d -side "top" -fill x -padx 4 -pady 4 + + button $top.close -text "Close" -width 10 -command [list destroy $top] \ + -default active + pack $top.close -side bottom -pady 4 + bind $top [list destroy $top] + bind $top [list destroy $top] +} + +# Add a registry item to a menu, if supported. +proc addRegistryToMenu {m} { + if {$::tcl_platform(platform) eq "windows"} { + if {![catch {package require registry}]} { + $m add separator + $m add command -label "Setup Registry" -underline 6 \ + -command makeRegistryWin + } + } +} +#---------------------------------------------------------------------- +# Nagelfar, a syntax checker for Tcl. +# Copyright (c) 1999-2005, Peter Spjuth +# +# This program is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 2 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program; see the file COPYING. If not, write to +# the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +# Boston, MA 02111-1307, USA. +# +#---------------------------------------------------------------------- +# preferences.tcl +#---------------------------------------------------------------------- + +# Save default options +proc saveOptions {} { + if {[catch {set ch [open "~/.nagelfarrc" w]}]} { + errEcho "Could not create options file." + return + } + + foreach i [array names ::Prefs] { + puts $ch [list set ::Prefs($i) $::Prefs($i)] + } + close $ch +} + +# Fill in default options and load user's saved file +proc getOptions {} { + array set ::Prefs { + warnBraceExpr 2 + warnShortSub 1 + strictAppend 0 + prefixFile 0 + forceElse 1 + noVar 0 + warnUnusedVar 0 + warnUnusedVarFilter {args} + severity N + editFileBackup 1 + editFileFont {Courier 10} + resultFont {Courier 10} + editor internal + extensions {.tcl .test .adp .tk} + exitcode 0 + html 0 + htmlprefix "" + } + + # Do not load anything during test + if {[info exists ::_nagelfar_test]} return + + foreach candidate {.nagelfarrc ~/.nagelfarrc} { + if {[file exists $candidate]} { + interp create -safe loadinterp + interp expose loadinterp source + interp eval loadinterp source $candidate + array set ::Prefs [interp eval loadinterp array get ::Prefs] + interp delete loadinterp + break + } + } +} + +# Add an "Options" cascade to a menu +proc addOptionsMenu {m} { + $m add cascade -label "Options" -underline 0 -menu $m.mo + menu $m.mo + + $m.mo add cascade -label "Result Window Font" -menu $m.mo.mo + menu $m.mo.mo + $m.mo.mo add radiobutton -label "Small" \ + -variable ::Prefs(resultFont) -value "Courier 8" \ + -command {font configure ResultFont -size 8} + $m.mo.mo add radiobutton -label "Medium" \ + -variable ::Prefs(resultFont) -value "Courier 10" \ + -command {font configure ResultFont -size 10} + $m.mo.mo add radiobutton -label "Large" \ + -variable ::Prefs(resultFont) -value "Courier 14" \ + -command {font configure ResultFont -size 14} + + $m.mo add cascade -label "Editor" -menu $m.mo.med + menu $m.mo.med + $m.mo.med add radiobutton -label "Internal" \ + -variable ::Prefs(editor) -value internal + $m.mo.med add radiobutton -label "Emacs" \ + -variable ::Prefs(editor) -value emacs + $m.mo.med add radiobutton -label "Vim" \ + -variable ::Prefs(editor) -value vim + + if {$::tcl_platform(platform) == "windows"} { + $m.mo.med add radiobutton -label "Pfe" \ + -variable ::Prefs(editor) -value pfe + } + + $m.mo add separator + + $m.mo add cascade -label "Severity level" -menu $m.mo.ms + menu $m.mo.ms + $m.mo.ms add radiobutton -label "Show All (E/W/N)" \ + -variable ::Prefs(severity) -value N + $m.mo.ms add radiobutton -label {Show Warnings (E/W)} \ + -variable ::Prefs(severity) -value W + $m.mo.ms add radiobutton -label {Show Errors (E)} \ + -variable ::Prefs(severity) -value E + + $m.mo add checkbutton -label "Warn about shortened subcommands" \ + -variable ::Prefs(warnShortSub) + $m.mo add cascade -label "Braced expressions" -menu $m.mo.mb + menu $m.mo.mb + $m.mo.mb add radiobutton -label "Allow unbraced" \ + -variable ::Prefs(warnBraceExpr) -value 0 + $m.mo.mb add radiobutton -label {Allow 'if [cmd] {xxx}'} \ + -variable ::Prefs(warnBraceExpr) -value 1 + $m.mo.mb add radiobutton -label "Warn on any unbraced" \ + -variable ::Prefs(warnBraceExpr) -value 2 + $m.mo add checkbutton -label "Enforce else keyword" \ + -variable ::Prefs(forceElse) + $m.mo add checkbutton -label "Strict (l)append" \ + -variable ::Prefs(strictAppend) + $m.mo add checkbutton -label "Disable variable checking" \ + -variable ::Prefs(noVar) + + $m.mo add cascade -label "Script encoding" -menu $m.mo.me + menu $m.mo.me + $m.mo.me add radiobutton -label "Ascii" \ + -variable ::Nagelfar(encoding) -value ascii + $m.mo.me add radiobutton -label "Iso8859-1" \ + -variable ::Nagelfar(encoding) -value iso8859-1 + $m.mo.me add radiobutton -label "System ([encoding system])" \ + -variable ::Nagelfar(encoding) -value system + + + $m.mo add separator + $m.mo add command -label "Save Options" -command saveOptions + +} +#---------------------------------------------------------------------- +# Nagelfar, a syntax checker for Tcl. +# Copyright (c) 2013, Peter Spjuth +# +# This program is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 2 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program; see the file COPYING. If not, write to +# the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +# Boston, MA 02111-1307, USA. +# +#---------------------------------------------------------------------- +# plugin.tcl +#---------------------------------------------------------------------- + +proc PluginSearchPath {} { + set dirs [list . ./plugins] + lappend dirs [file join $::thisDir .. ..] + lappend dirs [file join $::thisDir .. .. plugins] + lappend dirs [file join $::thisDir .. plugins] + foreach d $::Nagelfar(pluginPath) { + lappend dirs $d + } + return $dirs +} + +# Locate plugin source +proc LocatePlugin {plugin} { + set src "" + set dirs [PluginSearchPath] + + foreach dir $dirs { + set dir [file normalize $dir] + set files {} + lappend files [file join $dir $plugin] + lappend files [file join $dir $plugin.tcl] + foreach file $files { + if {![file exists $file]} continue + if {![file isfile $file]} continue + if {![file readable $file]} continue + set ch [open $file r] + set data [read $ch 20] + close $ch + if {[string match "##Nagelfar Plugin*" $data]} { + set src $file + break + } + } + if {$src ne ""} break + } + return $src +} + +proc createPluginInterp {plugin} { + set src [LocatePlugin $plugin] + + if {$src eq ""} { + return "" + } + # Create interpreter + set pi [interp create -safe] + + # Load source + $pi invokehidden -global source $src + $pi eval [list set ::WhoAmI [file rootname [file tail $src]]] + interp share {} stdout $pi + + # Expose needed commands + #interp expose $pi fconfigure ;# ?? + interp hide $pi close + + # Register what hooks it has in the global variables + foreach func {statementRaw statementWords earlyExpr lateExpr varWrite + varRead syntaxComment + } { + if {[$pi eval info proc $func] ne ""} { + # var names start with uppercase + set func [string toupper $func 0 0] + lappend ::Nagelfar(pluginHooks$func) $pi + set ::Nagelfar(plugin$func) 1 + } + } + return $pi +} + +proc resetPluginData {} { + foreach func {StatementRaw StatementWords EarlyExpr LateExpr VarWrite + VarRead SyntaxComment + } { + set ::Nagelfar(pluginHooks$func) {} + set ::Nagelfar(plugin$func) 0 + } + set ::Nagelfar(pluginInterp) {} +} + +proc initPlugin {} { + resetPluginData + foreach plugin $::Nagelfar(plugin) { + set pinterp [createPluginInterp $plugin] + if {$pinterp eq ""} { + puts "Bad plugin: $plugin" + printPlugins + exit 1 + } + lappend ::Nagelfar(pluginInterp) $pinterp + set ::Nagelfar(pluginNames,$pinterp) $plugin + } +} + +proc finalizePlugin {} { + foreach pi $::Nagelfar(pluginInterp) { + if {[$pi eval info proc finalizePlugin] ne ""} { + set x [$pi eval finalizePlugin] + if {[catch {llength $x}] || ([llength $x] % 2) != 0} { + errorMsg E "Plugin $::Nagelfar(pluginNames,$pi) returned malformed list from finalizePlugin" 0 + } else { + foreach {cmd value} $x { + switch $cmd { + error { errorMsg E $value 0 } + warning { errorMsg W $value 0 } + note { errorMsg N $value 0 } + default { + errorMsg E "Plugin $::Nagelfar(pluginNames,$pi) returned bad keyword '$cmd' from finalizePlugin" 0 + } + } + } + } + } + + interp delete $pi + unset ::Nagelfar(pluginNames,$pi) + } + + resetPluginData +} + +proc pluginHandleWriteHeader {ch} { + foreach pi $::Nagelfar(pluginInterp) { + if {[$pi eval info proc writeHeader] ne ""} { + set x [$pi eval writeHeader] + foreach value $x { + if {![regexp "^\#\#nagelfar\[^\n\]" $value]} { + errorMsg E "Plugin $::Nagelfar(pluginNames,$pi) returned illegal comment" 0 + } else { + puts $ch $value + } + } + } + } +} + +proc printPlugin {plugin} { + set src [LocatePlugin $plugin] + if {$src eq ""} { + printPlugins + return + } + set ch [open $src] + puts -nonewline [read $ch] + close $ch +} + +proc listPlugins {} { + set dirs [PluginSearchPath] + + foreach dir $dirs { + set dir [file normalize $dir] + set files [glob -nocomplain [file join $dir *.tcl]] + foreach file $files { + set file [file normalize $file] + if {[info exists done($file)]} continue + if {![file exists $file]} continue + if {![file isfile $file]} continue + if {![file readable $file]} continue + + set done($file) 1 + set ch [open $file r] + set data [read $ch 200] + close $ch + if {[regexp {^\#\#Nagelfar Plugin :(.*?)(\n|$)} $data -> descr]} { + set result([file rootname [file tail $file]]) $descr + } + } + } + set resultSort {} + foreach elem [lsort -dictionary [array names result]] { + lappend resultSort $elem $result($elem) + } + return $resultSort +} + +proc printPlugins {} { + set plugins [listPlugins] + if {[llength $plugins] == 0} { + puts "No plugins found." + return + } + puts "Available plugins:" + foreach {plugin descr} $plugins { + puts "Plugin \"$plugin\" : $descr" + } +} + +# Generic handler to call plugin +proc PluginHandle {pi what indata outdataName knownVarsName index} { + upvar 1 $outdataName outdata $knownVarsName knownVars + + set outdata $indata + set info [list namespace [currentNamespace] \ + caller [currentProc] \ + file $::currentFile \ + firstpass $::Nagelfar(firstpass) \ + vars $knownVars] + + set x [$pi eval [list $what $indata $info]] + + if {[catch {llength $x}] || ([llength $x] % 2) != 0} { + errorMsg E "Plugin $::Nagelfar(pluginNames,$pi) returned malformed list from $what" $index + return + } + + foreach {cmd value} $x { + switch $cmd { + replace { + set outdata $value + } + comment { + foreach line [split $value \n] { + checkComment $line $index knownVars + } + } + error {errorMsg E $value $index 1} + warning {errorMsg W $value $index 1} + note {errorMsg N $value $index 1} + default { + errorMsg E "Plugin $::Nagelfar(pluginNames,$pi) returned bad keyword '$cmd' from $what" $index + } + } + } +} + +# This is called to let a plugin react to a statement, pre-substitution +proc pluginHandleStatementRaw {stmtName knownVarsName index} { + upvar 1 $stmtName stmt $knownVarsName knownVars + + set outdata $stmt + foreach pi $::Nagelfar(pluginHooksStatementRaw) { + PluginHandle $pi statementRaw $stmt outdata knownVars $index + } + set stmt $outdata +} + +# This is called to let a plugin react to a statement, pre-substitution +proc pluginHandleStatementWords {wordsName knownVarsName index} { + upvar 1 $wordsName words $knownVarsName knownVars + + foreach pi $::Nagelfar(pluginHooksStatementWords) { + PluginHandle $pi statementWords $words outdata knownVars $index + # A replacement must be a list + if {[string is list $outdata]} { + set words $outdata + } else { + errorMsg E "Plugin $::Nagelfar(pluginNames,$pi) returned malformed replacement from statementWords" $index + } + } +} + +# This is called to let a plugin react to an expression, pre-substitution +proc pluginHandleEarlyExpr {expName knownVarsName index} { + upvar 1 $expName exp $knownVarsName knownVars + + set outdata $exp + foreach pi $::Nagelfar(pluginHooksEarlyExpr) { + PluginHandle $pi earlyExpr $exp outdata knownVars $index + } + set exp $outdata +} + +# This is called to let a plugin react to an expression, post-substitution +proc pluginHandleLateExpr {expName knownVarsName index} { + upvar 1 $expName exp $knownVarsName knownVars + + foreach pi $::Nagelfar(pluginHooksLateExpr) { + PluginHandle $pi lateExpr $exp outdata knownVars $index + + # A replacement expression must not have commands in it + if {$exp ne $outdata} { + # It has been replaced + # a '[' is forbidden but an '\[' is ok + if {![regexp {^\[|[^\\]\[} $outdata]} { + set exp $outdata + } else { + errorMsg E "Plugin $::Nagelfar(pluginNames,$pi) returned malformed replacement from lateExpr" $index + } + } + } +} + +# This is called to let a plugin react to a variable write +proc pluginHandleVarWrite {varName knownVarsName index} { + upvar 1 $varName var $knownVarsName knownVars + + foreach pi $::Nagelfar(pluginHooksVarWrite) { + PluginHandle $pi varWrite $var outdata knownVars $index + set var $outdata + } +} + +# This is called to let a plugin react to a variable read +proc pluginHandleVarRead {varName knownVarsName index} { + upvar 1 $varName var $knownVarsName knownVars + + foreach pi $::Nagelfar(pluginHooksVarRead) { + PluginHandle $pi varRead $var outdata knownVars $index + set var $outdata + } +} + +# This is called to let a plugin see syntax comments +proc pluginHandleComment {type opts} { + set res false + foreach pi $::Nagelfar(pluginHooksSyntaxComment) { + if {[$pi eval syntaxComment $type $opts]} { + set res true + } + } + return $res +} +#---------------------------------------------------------------------- +# Nagelfar, a syntax checker for Tcl. +# Copyright (c) 1999-2012, Peter Spjuth +# +# This program is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 2 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program; see the file COPYING. If not, write to +# the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +# Boston, MA 02111-1307, USA. +# +#---------------------------------------------------------------------- +# startup.tcl +#---------------------------------------------------------------------- + +# Output usage info and exit +proc usage {} { + puts $::version + puts {Usage: nagelfar [options] scriptfile ... + -help : Show usage. + -gui : Start with GUI even when files are specified. + -s : Include a database file. (More than one is allowed.) + : If is "_", it adds the default database. + -encoding : Read script with this encoding. + -filter

: Any message that matches the glob pattern is suppressed. + -severity : Set severity level filter to N/W/E (default N). + -html : Generate html-output. + -prefix : Prefix for line anchors (html output) + -novar : Disable variable checking. + -WexprN : Sets expression warning level to N. + 2 (def) = Warn about any unbraced expression. + 1 = Don't warn on single commands. "if [apa] {...}" is ok. + -WsubN : Sets subcommand warning level to N. + 1 (def) = Warn about shortened subcommands. + -WelseN : Enforce else keyword. Default 1. + -Wunusedvar : Check for unused variables. + -WunusedvarFilter : List of names to ignore for unused check. + -strictappend : Enforce having an initialised variable in (l)append. + -tab : Tab size, default is 8. Used for indentation checks. + -len : Enforce max line length. + -header : Create a "header" file with syntax info for scriptfiles. + -instrument : Instrument source file for code coverage. + -markup : Markup source file with code coverage result. + -markupfull : Like -markup, but includes stats for covered blocks. + -idir

: Store code coverage files in this dir. + -nosource : When instrumenting, do not overload source. + -quiet : Suppress non-syntax output. + -glob : Add matching files to scriptfiles to check. + -plugin : Run with this plugin. + -plugindump : Print contents of plugin source + -pluginlist : List known plugins + -pluginpath : Configure plugin search path. + -H : Prefix each error line with file name. + -exitcode : Return status code 2 for any error or 1 for warning. + -dbpicky : Enable checking of syntax DB. + -pkgpicky : Warn about redudant package require. + -trace : Output debug info to file} + exit +} + +# Initialise global variables with defaults. +proc StartUp {} { + set ::Nagelfar(db) {} + set ::Nagelfar(files) {} + set ::Nagelfar(gui) 0 + set ::Nagelfar(quiet) 0 + set ::Nagelfar(filter) {} + set ::Nagelfar(2pass) 1 + set ::Nagelfar(encoding) system + set ::Nagelfar(dbpicky) 0 + set ::Nagelfar(pkgpicky) 0 + set ::Nagelfar(withCtext) 0 + set ::Nagelfar(instrument) 0 + set ::Nagelfar(nosource) 0 + set ::Nagelfar(markup) 0 + set ::Nagelfar(idir) "" + set ::Nagelfar(header) "" + set ::Nagelfar(tabReg) { {0,7}\t| {8,8}} + set ::Nagelfar(tabSub) [string repeat " " 8] + set ::Nagelfar(tabMap) [list \t $::Nagelfar(tabSub)] + set ::Nagelfar(lineLen) 0 + set ::Nagelfar(procs) {} + set ::Nagelfar(stop) 0 + set ::Nagelfar(trace) "" + set ::Nagelfar(plugin) {} + + if {![info exists ::Nagelfar(embedded)]} { + set ::Nagelfar(embedded) 0 + } + + getOptions +} + +# Procedure to perform a check when embedded. +# If iscontents is set fpath and dbPath contains the file contents, not names +proc synCheck {fpath dbPath {iscontents 0}} { + if {$iscontents} { + set ::Nagelfar(scriptContents) $fpath + set ::Nagelfar(files) {} + } else { + set ::Nagelfar(files) [list $fpath] + } + set ::Nagelfar(allDb) {} + set ::Nagelfar(allDbView) {} + set ::Nagelfar(allDb) [list $dbPath] + set ::Nagelfar(allDbView) [list [file tail $dbPath] "(app)"] + if {$iscontents} { + set ::Nagelfar(dbContents) $dbPath + set ::Nagelfar(db) {} + } else { + set ::Nagelfar(db) [list $dbPath] + } + set ::Nagelfar(embedded) 1 + set ::Nagelfar(chkResult) "" + # FIXA: Allow control of plugin when embedded? + set ::Nagelfar(plugin) {} + initPlugin + doCheck + if {$iscontents} { + unset ::Nagelfar(scriptContents) + unset ::Nagelfar(dbContents) + } + return $::Nagelfar(chkResult) +} + +# Helper for debug tracer +# Make a compact string for a command to give a decent output in trace +proc traceCompactCmd {cmd} { + if {[info exists ::memoize_traceCompactCmd($cmd)]} { + return $::memoize_traceCompactCmd($cmd) + } + set res {} + foreach elem $cmd { + set cut 0 + set i [string first \n $elem] + if {$i >= 0} { + set elem [string range $elem 0 [expr {$i - 1}]]\\n + set cut 1 + } + if {[string length $elem] > 40} { + set elem [string range $elem 0 39] + set cut 1 + } + if {$cut} { + lappend res $elem... + } else { + lappend res $elem + } + } + set ::memoize_traceCompactCmd($cmd) $res + return $res +} + +# Debug tracer +proc traceCmd {cmd args} { + set cmd [traceCompactCmd $cmd] + set what [lindex $args end] + set args [lrange $args 0 end-1] + set ch [open $::Nagelfar(trace) a] + if {$what eq "enter"} { + puts $ch "$cmd" + } else { + foreach {code res} $args break + set res [traceCompactCmd [list $res]] + puts $ch "$cmd --> $code [lindex $res 0]" + #if {[string match splitScript*bin/sh* $cmd]} exit + } + close $ch +} + +# Global code is only run first time to allow re-sourcing +if {![info exists gurka]} { + set gurka 1 + + StartUp + + if {[info exists _nagelfar_test]} return + # To use Nagelfar embedded, set ::Nagelfar(embedded) 1 + # before sourcing nagelfar.tcl. + if {$::Nagelfar(embedded)} return + + # Locate default syntax database(s) + set ::Nagelfar(allDb) {} + set ::Nagelfar(allDbView) {} + set apa {} + lappend apa [file join [pwd] syntaxdb.tcl] + eval lappend apa [glob -nocomplain [file join [pwd] syntaxdb*.tcl]] + + lappend apa [file join $::dbDir syntaxdb.tcl] + eval lappend apa [glob -nocomplain [file join $::dbDir syntaxdb*.tcl]] + set pdbDir [file join $::dbDir packagedb] + eval lappend apa [glob -nocomplain [file join $pdbDir *db*.tcl]] + + set ::Nagelfar(pluginPath) {} + + foreach file $apa { + if {[file isfile $file] && [file readable $file] && \ + [lsearch $::Nagelfar(allDb) $file] == -1} { + lappend ::Nagelfar(allDb) $file + if {[file dirname $file] == $::dbDir} { + lappend ::Nagelfar(allDbView) "[file tail $file] (app)" + } elseif {[file dirname $file] == $pdbDir} { + lappend ::Nagelfar(allDbView) "[file tail $file] (app)" + } else { + lappend ::Nagelfar(allDbView) [fileRelative [pwd] $file] + } + } + } + + # Parse command line options + for {set i 0} {$i < $argc} {incr i} { + set arg [lindex $argv $i] + switch -glob -- $arg { + --h* - + -h - -hel* { + usage + } + -s { + incr i + set arg [lindex $argv $i] + if {$arg eq "_"} { + # Add the first, or none if allDb is empty + lappend ::Nagelfar(db) {*}[lrange $::Nagelfar(allDb) 0 0] + } elseif {[file isfile $arg] && [file readable $arg]} { + lappend ::Nagelfar(db) $arg + lappend ::Nagelfar(allDb) $arg + lappend ::Nagelfar(allDbView) $arg + } else { + # Look through allDb for a match + set found 0 + foreach db $::Nagelfar(allDb) { + if {$arg eq $db || $arg eq [file tail $db]} { + lappend ::Nagelfar(db) $db + set found 1 + break + } + } + if {!$found} { + puts stderr "Cannot read \"$arg\"" + } + } + } + -editor { + incr i + set arg [lindex $argv $i] + switch -glob -- $arg { + ema* {set ::Prefs(editor) emacs} + inte* {set ::Prefs(editor) internal} + vi* {set ::Prefs(editor) vim} + default { + puts stderr "Bad -editor option: \"$arg\"" + } + } + } + -encoding { + incr i + set enc [lindex $argv $i] + if {$enc eq ""} {set enc system} + if {[lsearch -exact [encoding names] $enc] < 0} { + puts stderr "Bad encoding name: \"$enc\"" + set enc system + } + set ::Nagelfar(encoding) $enc + } + -H { + set ::Prefs(prefixFile) 1 + } + -exitcode { + set ::Prefs(exitcode) 1 + } + -2pass { + set ::Nagelfar(2pass) 1 + } + -gui { + set ::Nagelfar(gui) 1 + } + -quiet { + set ::Nagelfar(quiet) 1 + } + -header { + incr i + set arg [lindex $argv $i] + set ::Nagelfar(header) $arg + # Put checks down as much as possible + array set ::Prefs { + warnBraceExpr 0 + warnShortSub 0 + strictAppend 0 + forceElse 0 + noVar 1 + severity E + } + } + -instrument { + set ::Nagelfar(instrument) 1 + # Put checks down as much as possible + array set ::Prefs { + warnBraceExpr 0 + warnShortSub 0 + strictAppend 0 + forceElse 0 + noVar 1 + severity E + } + } + -nosource { + set ::Nagelfar(nosource) 1 + } + -markup* { + set ::Nagelfar(markup) [expr {1 + ($arg eq "-markupfull")}] + } + -idir { + incr i + set arg [lindex $argv $i] + set ::Nagelfar(idir) $arg + } + -plugin { + incr i + set arg [lindex $argv $i] + lappend ::Nagelfar(plugin) $arg + } + -plugindump { + incr i + set arg [lindex $argv $i] + printPlugin $arg + exit + } + -pluginlist { + printPlugins + exit + } + -pluginpath { + incr i + set arg [lindex $argv $i] + lappend ::Nagelfar(pluginPath) $arg + } + -novar { + set ::Prefs(noVar) 1 + } + -Wunusedvar { + set ::Prefs(warnUnusedVar) 1 + } + -WunusedvarFilter { + incr i + set arg [lindex $argv $i] + lappend ::Prefs(warnUnusedVarFilter) $arg + } + -dbpicky { # A debug thing to help make a more complete database + set ::Nagelfar(dbpicky) 1 + } + -pkgpicky { # A debug thing to help make a more complete database + set ::Nagelfar(pkgpicky) 1 + } + -Wexpr* { + set ::Prefs(warnBraceExpr) [string range $arg 6 end] + } + -Wsub* { + set ::Prefs(warnShortSub) [string range $arg 5 end] + } + -Welse* { + set ::Prefs(forceElse) [string range $arg 6 end] + } + -strictappend { + set ::Prefs(strictAppend) 1 + } + -filter { + incr i + addFilter [lindex $argv $i] + } + -severity { + incr i + set ::Prefs(severity) [lindex $argv $i] + if {![regexp {^[EWN]$} $::Prefs(severity)]} { + puts "Bad severity level '$::Prefs(severity)',\ + should be E/W/N." + exit + } + } + -html { + set ::Prefs(html) 1 + } + -prefix { + incr i + set ::Prefs(htmlprefix) [lindex $argv $i] + } + -len { + incr i + set arg [lindex $argv $i] + if {![string is integer -strict $arg] || $arg < 1} { + puts "Bad len value '$arg'" + exit + } + set ::Nagelfar(lineLen) $arg + } + -tab { + incr i + set arg [lindex $argv $i] + if {![string is integer -strict $arg] || \ + $arg < 2 || $arg > 20} { + puts "Bad tab value '$arg'" + exit + } + set ::Nagelfar(tabReg) " {0,[expr {$arg - 1}]}\t| {$arg,$arg}" + set ::Nagelfar(tabSub) [string repeat " " $arg] + set ::Nagelfar(tabMap) [list \t $::Nagelfar(tabSub)] + } + -glob { + incr i + set files [glob -nocomplain [lindex $argv $i]] + set ::Nagelfar(files) [concat $::Nagelfar(files) $files] + } + -trace { + # Turn on debug tracer and set its output file name + incr i + set ::Nagelfar(trace) [lindex $argv $i] + } + -* { + puts "Unknown option $arg" + usage + } + default { + lappend ::Nagelfar(files) $arg + } + } + } + + if {$::Nagelfar(markup)} { + instrumentMarkup [lindex $::Nagelfar(files) 0] \ + [expr {$::Nagelfar(markup) == 2}] + exit + } + # Sanity check + if {$::Nagelfar(idir) ne "" && !$::Nagelfar(instrument)} { + puts "Option -idir can only be used with -instrument or -markup*" + exit + } + + # Initialise plugin system + initPlugin + + # Use default database if none were given + if {[llength $::Nagelfar(db)] == 0} { + if {[llength $::Nagelfar(allDb)] != 0} { + lappend ::Nagelfar(db) [lindex $::Nagelfar(allDb) 0] + } + } + + # If we are on Windows and Tk is already loaded it means we run in + # wish, and there is no stdout. Thus non-gui is pointless. + if {!$::Nagelfar(gui) && $::tcl_platform(platform) eq "windows" && + [package provide Tk] ne ""} { + set ::Nagelfar(gui) 1 + } + + if {$::Nagelfar(trace) ne ""} { + # Turn on debug tracer and initialise its output file + set ch [open $::Nagelfar(trace) w] + close $ch + foreach cmd [info procs] { + # Trace all procedures but those involved in the trace command + if {$cmd in {trace proc traceCmd traceCompactCmd set open puts close}} continue + trace add execution $cmd enter traceCmd + trace add execution $cmd leave traceCmd + } + } + + # If there is no file specified, try invoking a GUI + if {$::Nagelfar(gui) || [llength $::Nagelfar(files)] == 0} { + if {[catch {package require Tk}]} { + if {$::Nagelfar(gui)} { + puts stderr "Failed to start GUI" + exit 1 + } else { + puts stderr "No files specified" + exit 1 + } + } + # use ctext if available + if {![catch {package require ctext}]} { + if {![catch {package require ctext_tcl}]} { + if {[info procs ctext::setHighlightTcl] ne ""} { + set ::Nagelfar(withCtext) 1 + proc ctext::update {} {::update} + } + } + } + + catch {package require textSearch} + set ::Nagelfar(gui) 1 + makeWin + vwait forever + exit + } + + doCheck + + #_dumplogme + #if {[array size _stats] > 0} { + # array set _apa [array get _stats] + # parray _apa + # set sum 0 + # foreach name [array names _apa] { + # incr sum $_apa($name) + # } + # puts "Total $sum" + #} + exit [expr {$::Prefs(exitcode) ? $::Nagelfar(exitstatus) : 0}] +} Index: /branches/rel_apv_10_7_2_5_irule/usr/src/sys/click/app/proxy/proxy_amp.c =================================================================== --- /branches/rel_apv_10_7_2_5_irule/usr/src/sys/click/app/proxy/proxy_amp.c (revision 38731) +++ /branches/rel_apv_10_7_2_5_irule/usr/src/sys/click/app/proxy/proxy_amp.c (working copy) @@ -34,6 +34,8 @@ #include +#include + #ifdef ATCP_MM #include extern atcp_zone_t uproxy_event_zone; @@ -1913,6 +1915,9 @@ sf_send_event_slb_find_rs(SF_APP_SLB_HTTP, SF_HTTP_EVENT_SLB_FIND_RS, clipcb, pcb, eh->eh.connect.rs_id, eh->eh.connect.gid, slb_rs_p->name, slb_group_p?slb_group_p->name:NULL); } + + // Record the generated RS information in the thread's hash table for SLB ePolicy + slb_ePolicy_connect_table_add_node(pcb); } conn_error: Index: /branches/rel_apv_10_7_2_5_irule/usr/src/sys/click/app/slb/slb.h =================================================================== --- /branches/rel_apv_10_7_2_5_irule/usr/src/sys/click/app/slb/slb.h (revision 38731) +++ /branches/rel_apv_10_7_2_5_irule/usr/src/sys/click/app/slb/slb.h (working copy) @@ -1241,6 +1241,7 @@ typedef struct _ePolicy_vs_setting{ int script_count; char runtime_script[MAX_EPOLICY_SCRIPTS][SEGMENT_MAX_EPOLICY_FILE_LEN]; + int have_socket_script; }ePolicy_vs_setting; /*a smaller structure to do hash lookup*/ Index: /branches/rel_apv_10_7_2_5_irule/usr/src/sys/click/app/slb/slb_ePolicy_connect_rbtree.h =================================================================== --- /branches/rel_apv_10_7_2_5_irule/usr/src/sys/click/app/slb/slb_ePolicy_connect_rbtree.h (revision 0) +++ /branches/rel_apv_10_7_2_5_irule/usr/src/sys/click/app/slb/slb_ePolicy_connect_rbtree.h (working copy) @@ -0,0 +1,676 @@ +/*---------------------------------------------------------------------------- + * + * Copyright (C) 2024 + * ArrayNetworks Inc. All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification is not permitted unless authorized in writing by a duly + * appointed officer of ArrayNetworks Inc. or its derivatives + * + * 1. + * Create a dedicated ePolicy thread for each ATCP L4 thread. + * File: + * - usr/src/sys/sys/smp.h + * - usr/click/lib/libuinet-atcp/sys/click/netinet/click_input.c + * - usr/src/sys/click/kern/click_queue.c + * - usr/click/lib/libuinet-atcp/lib/libuinet/uinet_if_dpdk_host.c + * - usr/click/lib/libuinet-atcp/lib/libuinet/uinet_if_dpdk.c + * - usr/click/lib/libuinet-atcp/lib/libuinet/uinet_subr_smp.c + * + * 2. + * Check the mbuf; if it is a corresponding VS and the ePolicy script is set, + * dispatch the packet to the dedicated ePolicy thread. + * File: + * - usr/src/sys/click/net/click_ether.c + * + * 3. + * Record the generated RS information in the thread's hash table + * (implemented using a red-black tree and a doubly linked list). + * File: + * - usr/src/sys/click/app/proxy/proxy_amp.c + * + * 4. + * Check the mbuf; if it is an RS packet recorded in the hash table, + * dispatch it to the same ePolicy thread as the corresponding VS. + * File: + * - usr/src/sys/click/net/click_ether.c + * + * 5. + * When the RS connection is closed, remove it from the hash table. + * File: + * - usr/click/lib/libuinet-atcp/sys/click/netinet/click_input.c + * + * Use the BSD library's red-black tree and hash functions. + * Use jenkins_hash32 as the key, + * and implement collision handling with a doubly linked list, utilizing hash32_buf. + * + * 2024/10/28 Tseng, Wei-Kai Created for SLB ePolicy + * + *--------------------------------------------------------------------------- + */ + +#ifndef _SLB_EPOLICY_CONNECT_RBTREE_H_ +#define _SLB_EPOLICY_CONNECT_RBTREE_H_ + +#define _SLB_EPOLICY_CONNECT_RBTREE_H_DEBUG_ 0 + +#include +#include +#include +#include + +#include + +#define cur_slb_ePolicy_tree_root slb_ePolicy_connect_tree[curatcp - atcp_L4_id_min] +#define get_slb_ePolicy_tree_root(idx) slb_ePolicy_connect_tree[idx - atcp_L4_id_min] + +#if _SLB_EPOLICY_CONNECT_RBTREE_H_DEBUG_ +static int node_rm_count = 0; +static int node_add_count = 0; +#endif + +/* Connection information */ +typedef struct slb_ePolicy_connect_node { + /* Red–black tree entry point */ + RB_ENTRY(slb_ePolicy_connect_node) entry; + + /* A doubly linked list is used when a hash collision occurs. */ + struct slb_ePolicy_connect_node *next; + struct slb_ePolicy_connect_node *prev; + + /* Data */ + uint32_t tree_key; + uint32_t list_key; + + uint8_t is_ipv6; + + uint8_t protocol; + + union { + struct in_addr ip4; + struct in6_addr ip6; + } local_ip; + + union { + struct in_addr ip4; + struct in6_addr ip6; + } remote_ip; + + uint16_t local_port; + uint16_t remote_port; + +} slb_ePolicy_connect_node_t; + +/* Comparison function used for red-black trees. */ +static __inline int +slb_ePolicy_connect_node_compare(slb_ePolicy_connect_node_t *node_a, slb_ePolicy_connect_node_t *node_b) { + return (node_a->tree_key < node_b->tree_key ? -1 : node_a->tree_key > node_b->tree_key); +} + +/* Define the structure and functions for a red-black tree. */ +RB_HEAD(slb_ePolicy_connect_node_tree, slb_ePolicy_connect_node); +RB_PROTOTYPE_STATIC(slb_ePolicy_connect_node_tree, slb_ePolicy_connect_node, entry, slb_ePolicy_connect_node_compare) +RB_GENERATE_STATIC(slb_ePolicy_connect_node_tree, slb_ePolicy_connect_node, entry, slb_ePolicy_connect_node_compare) + +/* Each L4 thread has its own red-black tree. */ +extern struct slb_ePolicy_connect_node_tree *slb_ePolicy_connect_tree[ATCP_MAXTHREADS]; + +/* Self hash function */ +static __inline void +slb_ePolicy_connect_node_self_hash( + uint32_t *return_hash_0, uint32_t *return_hash_1, + uint8_t is_ipv6, uint8_t protocol, + void *local_ip, uint16_t local_port, + void *remote_ip, uint16_t remote_port +) { + uint32_t key; + uint32_t hash_0 = 0; + uint32_t hash_1 = 0; + + if (is_ipv6) { + struct in6_addr *local_ipv6 = (struct in6_addr *)local_ip; + struct in6_addr *remote_ipv6 = (struct in6_addr *)remote_ip; + + for (int i = 0; i < 4; i++) { + hash_0 ^= ntohl(local_ipv6->__u6_addr.__u6_addr32[i]); + } + + for (int i = 0; i < 4; i++) { + hash_0 ^= (ntohl(remote_ipv6->__u6_addr.__u6_addr32[i]) << (i * 8)); + } + + for (int i = 0; i < 4; i++) { + hash_1 ^= ntohl(remote_ipv6->__u6_addr.__u6_addr32[i]); + } + + for (int i = 0; i < 4; i++) { + hash_1 ^= (ntohl(local_ipv6->__u6_addr.__u6_addr32[i]) << (i * 8)); + } + + } else { + struct in_addr *local_ipv4 = (struct in_addr *)local_ip; + struct in_addr *remote_ipv4 = (struct in_addr *)remote_ip; + + hash_0 = local_ipv4->s_addr; + hash_0 ^= (remote_ipv4->s_addr << 16) | (remote_ipv4->s_addr >> 16); + + hash_1 = remote_ipv4->s_addr; + hash_1 ^= (local_ipv4->s_addr << 16) | (local_ipv4->s_addr >> 16); + } + + hash_0 ^= local_port | (remote_port << 16); + hash_0 ^= protocol; + + hash_0 ^= (hash_0 << 13); + hash_0 ^= (hash_0 >> 17); + hash_0 ^= (hash_0 << 5); + + hash_1 ^= (local_port << 16) | remote_port; + hash_1 ^= protocol; + + hash_1 ^= (hash_0 << 13); + hash_1 ^= (hash_0 >> 17); + hash_1 ^= (hash_0 << 5); + + *return_hash_0 = hash_0; + *return_hash_1 = hash_1; +} + +/* Hash function for tree. */ +static __inline uint32_t +slb_ePolicy_connect_node_hash( + uint8_t is_ipv6, uint8_t protocol, + void *local_ip, uint16_t local_port, + void *remote_ip, uint16_t remote_port +) { + uint32_t key; + uint32_t hash_0 ; + uint32_t hash_1; + + slb_ePolicy_connect_node_self_hash( + &hash_0, &hash_1, + is_ipv6, protocol, + local_ip, local_port, + remote_ip, remote_port + ); + + uint32_t data[] = { + hash_0, + hash_1 + }; + + key = jenkins_hash32(data, 2, hash_0 ^ hash_1); + + return key; +} + +/* Hash function for linked list. */ +static __inline uint32_t +slb_ePolicy_connect_node_list_hash( + uint8_t is_ipv6, uint8_t protocol, + void *local_ip, uint16_t local_port, + void *remote_ip, uint16_t remote_port, + uint32_t tree_key +) { + uint32_t key; + uint32_t hash_0 ; + uint32_t hash_1; + + slb_ePolicy_connect_node_self_hash( + &hash_0, &hash_1, + is_ipv6, protocol, + local_ip, local_port, + remote_ip, remote_port + ); + + uint32_t data[] = { + hash_0, + hash_1 + }; + + key = hash32_buf(data, 2, hash_0 ^ hash_1 ^ tree_key); + + return key; +} + +/* Initialize the key of the node. */ +static __inline void +slb_ePolicy_connect_node_init_key(slb_ePolicy_connect_node_t *node) { + uint32_t key; + uint32_t hash_0 ; + uint32_t hash_1; + + if (node->is_ipv6) { + slb_ePolicy_connect_node_self_hash( + &hash_0, &hash_1, + node->is_ipv6, node->protocol, + &node->local_ip.ip6, node->local_port, + &node->remote_ip.ip6, node->remote_port + ); + } else { + slb_ePolicy_connect_node_self_hash( + &hash_0, &hash_1, + node->is_ipv6, node->protocol, + &node->local_ip.ip4, node->local_port, + &node->remote_ip.ip4, node->remote_port + ); + } + + uint32_t data[] = { + hash_0, + hash_1 + }; + + node->tree_key = jenkins_hash32(data, 2, hash_0 ^ hash_1); + node->list_key = hash32_buf(data, 2, hash_0 ^ hash_1 ^ node->tree_key); +} + +/* Initialize the node of the red-black tree. */ +static __inline slb_ePolicy_connect_node_t * +slb_ePolicy_connect_node_create( + uint8_t is_ipv6, uint8_t protocol, + void *local_ip, uint16_t local_port, + void* remote_ip, uint16_t remote_port +) { + slb_ePolicy_connect_node_t *tmp_node = (slb_ePolicy_connect_node_t *)malloc(sizeof(slb_ePolicy_connect_node_t), M_TEMP, M_NOWAIT); + + tmp_node->next = NULL; + tmp_node->prev= NULL; + + tmp_node->is_ipv6 = is_ipv6 == 0? 0: 1; + + switch (protocol) + { + case IPPROTO_TCP: + tmp_node->protocol = IPPROTO_TCP; + break; + case IPPROTO_UDP: + tmp_node->protocol = IPPROTO_UDP; + break; + case IPPROTO_ICMP: + tmp_node->protocol = IPPROTO_ICMP; + break; + default: + tmp_node->protocol = 0; + } + + if (tmp_node->is_ipv6) { + memcpy(&tmp_node->local_ip.ip6, (struct in6_addr*)local_ip, sizeof(struct in6_addr)); + memcpy(&tmp_node->remote_ip.ip6, (struct in6_addr*)remote_ip, sizeof(struct in6_addr)); + } else { + memcpy(&tmp_node->local_ip.ip4, (struct in_addr*)local_ip, sizeof(struct in_addr)); + memcpy(&tmp_node->remote_ip.ip4, (struct in_addr*)remote_ip, sizeof(struct in_addr)); + } + + tmp_node->local_port = local_port; + tmp_node->remote_port = remote_port; + + slb_ePolicy_connect_node_init_key(tmp_node); + + return tmp_node; +} + +/* Initialize the red-black tree node using the PCB data. */ +static __inline slb_ePolicy_connect_node_t * +slb_ePolicy_connect_node_create_from_pcb(clickpcb_t *pcb) { + int pcb_type = 0; + switch (pcb->cp_type) { + case PCB_TCP: + pcb_type = IPPROTO_TCP; + break; + case PCB_UDP: + pcb_type = IPPROTO_UDP; + break; + case PCB_ICMP: + pcb_type = IPPROTO_ICMP; + break; + default: + pcb_type = 0; + } + + return slb_ePolicy_connect_node_create( + CLICKPCB_IS_IPV6(pcb), pcb_type, + &pcb->cp_localip, pcb->cp_localport, + &pcb->cp_remoteip, pcb->cp_remoteport + ); +} + +/* + * Detailed data comparison of nodes used in the linked list. + * return: + * - 0 for equal + * - 1 for not equal + */ +static __inline int +slb_ePolicy_connect_node_all_compare(slb_ePolicy_connect_node_t *node_a, slb_ePolicy_connect_node_t *node_b) { + if (node_a->tree_key != node_b->tree_key) { + return -1; + } + + if (node_a->list_key != node_b->list_key) { + return -1; + } + + if (node_a->is_ipv6 != node_b->is_ipv6) { + return -1; + } + + if (node_a->protocol != node_b->protocol) { + return -1; + } + + if (node_a->is_ipv6) { + if (memcmp(&node_a->local_ip.ip6, &node_b->local_ip.ip6, sizeof(struct in6_addr)) != 0) { + return -1; + } + + if (memcmp(&node_a->remote_ip.ip6, &node_b->remote_ip.ip6, sizeof(struct in6_addr)) != 0) { + return -1; + } + } else { + if (memcmp(&node_a->local_ip.ip4, &node_b->local_ip.ip4, sizeof(struct in_addr)) != 0) { + return -1; + } + + if (memcmp(&node_a->remote_ip.ip4, &node_b->remote_ip.ip4, sizeof(struct in_addr)) != 0) { + return -1; + } + } + + if (node_a->local_port != node_b->local_port) { + return -1; + } + + if (node_a->remote_port != node_b->remote_port) { + return -1; + } + + return 0; +} + +/* + * Search for a node in the red-black tree. + * return: + * - the node if found + * - NULL if not found + */ +static __inline slb_ePolicy_connect_node_t * +slb_ePolicy_connect_node_find( + struct slb_ePolicy_connect_node_tree *root, + slb_ePolicy_connect_node_t *data_node +) { + /* RB_FIND will return the node if found, otherwise it will return NULL. */ + slb_ePolicy_connect_node_t *tmp_node = + RB_FIND(slb_ePolicy_connect_node_tree, root, data_node); + + /* Check the contents of the node; if they are different, search in the linked list. */ + while(tmp_node != NULL && slb_ePolicy_connect_node_all_compare(tmp_node, data_node) != 0) { + tmp_node = tmp_node->next; + } + + return tmp_node; +} + +/* + * Insert a node into the red-black tree. + * return: + * - NULL is successful return NULL + * - already exists reutrn existing node + */ +static __inline slb_ePolicy_connect_node_t * +slb_ePolicy_connect_node_insert( + struct slb_ePolicy_connect_node_tree *root, + slb_ePolicy_connect_node_t *data_node +) { + slb_ePolicy_connect_node_t *tmp_node + = slb_ePolicy_connect_node_find(root, data_node); + + if (tmp_node == NULL) { +#if _SLB_EPOLICY_CONNECT_RBTREE_H_DEBUG_ + printf("node_add=%d, tree node\n", ++node_add_count); +#endif + /* + * RB_INSERT returns NULL if the insertion is successful; + * if the node already exists, it returns the existing node. + */ + return RB_INSERT(slb_ePolicy_connect_node_tree, root, data_node); + } + + /* Insert the node with the same key into the linked list in the red-black tree. */ + while (tmp_node->next) { + tmp_node = tmp_node->next; + } + tmp_node->next = data_node; + data_node->prev = tmp_node; + +#if _SLB_EPOLICY_CONNECT_RBTREE_H_DEBUG_ + printf("node_add=%d, list node\n", ++node_add_count); +#endif + return NULL; +} + +/* + * Removing a node from a red-black tree and linked list. + * return: + * - 1 for success + * - 0 for not found + */ +static __inline int +slb_ePolicy_connect_node_remove( + struct slb_ePolicy_connect_node_tree *root, + slb_ePolicy_connect_node_t *data_node +) { + slb_ePolicy_connect_node_t *tmp_node + = slb_ePolicy_connect_node_find(root, data_node); + + if (tmp_node != NULL) { + if (tmp_node->next == NULL && tmp_node->prev == NULL) { + RB_REMOVE(slb_ePolicy_connect_node_tree, root, tmp_node); + } else if (tmp_node->next != NULL && tmp_node->prev == NULL) { + tmp_node->next->prev = NULL; + RB_REMOVE(slb_ePolicy_connect_node_tree, root, tmp_node); + slb_ePolicy_connect_node_insert(root, tmp_node->next); + } else if (tmp_node->next == NULL && tmp_node->prev != NULL) { + tmp_node->prev->next = NULL; + tmp_node->prev = NULL; + } else { + tmp_node->prev->next = tmp_node->next; + tmp_node->next->prev = tmp_node->prev; + } + free(tmp_node, M_TEMP); +#if _SLB_EPOLICY_CONNECT_RBTREE_H_DEBUG_ + printf("***node_rm=%d\n", ++node_rm_count); +#endif + return 1; + } + return 0; +} + +/* Free the memory of the node. */ +static __inline void +free_slb_ePolicy_connect_node( + slb_ePolicy_connect_node_t *data_node +) { + free(data_node, M_TEMP); +} + +/* Insert the node into the corresponding table in the ePolicy thread using the PCB data. */ +static __inline void +slb_ePolicy_connect_table_add_node(clickpcb_t *pcb) { + if (atcp_ePolicy_id_min <= curatcp && curatcp <= atcp_ePolicy_id_max) { + + slb_ePolicy_connect_node_t *node = slb_ePolicy_connect_node_create_from_pcb(pcb); + + slb_ePolicy_connect_node_t *flag = slb_ePolicy_connect_node_insert(cur_slb_ePolicy_tree_root, node); + + /* For debug */ +#if _SLB_EPOLICY_CONNECT_RBTREE_H_DEBUG_ + char localip_str[128]; + char remoteip_str[128]; + int ip_flag = CLICKPCB_IS_IPV6(pcb) ? AF_INET6 : AF_INET; + inet_ntop(ip_flag, &(pcb->cp_localip), localip_str, 128); + inet_ntop(ip_flag, &(pcb->cp_remoteip), remoteip_str, 128); + + printf("add node, thread: %d, %s:%d_%s:%d, add_flag=%d, tree_key=%u, list_key=%u, has_next=%d, has_prev=%d\n", + curatcp, + localip_str, pcb->cp_localport, + remoteip_str, pcb->cp_remoteport, + flag == NULL? 1: 0, + node->tree_key, node->list_key, + node->next == NULL? 0: 1, + node->prev == NULL? 0: 1 + ); +#endif + } +} + +/* Remove the node from the corresponding table in the ePolicy thread using the PCB data. */ +static __inline void +slb_ePolicy_connect_table_rm_node(clickpcb_t *pcb) { + if ( + (atcp_ePolicy_id_min <= curatcp && curatcp <= atcp_ePolicy_id_max) && + (pcb->cp_type == PCB_TCP || pcb->cp_type == PCB_UDP || pcb->cp_type == PCB_ICMP) + ){ + int pcb_type = 0; + + switch (pcb->cp_type) { + case PCB_TCP: + pcb_type = IPPROTO_TCP; + break; + case PCB_UDP: + pcb_type = IPPROTO_UDP; + break; + case PCB_ICMP: + pcb_type = IPPROTO_ICMP; + break; + default: + pcb_type = 0; + } + + slb_ePolicy_connect_node_t *node = slb_ePolicy_connect_node_create_from_pcb(pcb); + + int remove_flag = 0; + + remove_flag = slb_ePolicy_connect_node_remove(cur_slb_ePolicy_tree_root, node); + + free_slb_ePolicy_connect_node(node); + + /* For debug */ +#if _SLB_EPOLICY_CONNECT_RBTREE_H_DEBUG_ + char localip_str[128]; + char remoteip_str[128]; + int ip_flag = CLICKPCB_IS_IPV6(pcb) ? AF_INET6 : AF_INET; + inet_ntop(ip_flag, &(pcb->cp_localip), localip_str, 128); + inet_ntop(ip_flag, &(pcb->cp_remoteip), remoteip_str, 128); + printf("rm node, thread: %d, %s:%d_%s:%d, rm_flag=%d, is_empty=%d\n", + curatcp, + localip_str, pcb->cp_localport, + remoteip_str, pcb->cp_remoteport, + remove_flag, + RB_EMPTY(cur_slb_ePolicy_tree_root) + ); +#endif + } +} + +/* Search for the data that the ePolicy thread needs to process through the mbuf data and return the target thread ID. */ +static __inline int +slb_ePolicy_connect_tcp_mbuf_thread_dispatcher(uint32_t atcpid, struct mbuf *m, struct tcphdr *tcph, int isipv6) { + struct ip *iph; + struct ip6_hdr *ip6; + slb_vs_t *vs; + + if (!isipv6) { + iph = mtod(m, struct ip *); + vs = slb_vs_lookup(iph->ip_dst.s_addr, ntohs(tcph->th_dport), IPPROTO_TCP); + } else { + ip6 = mtod(m, struct ip6_hdr*); + vs = slb_vs_lookup6(&ip6->ip6_dst, ntohs(tcph->th_dport), IPPROTO_TCP); + } + + if (vs != NULL && vs->is_attach_script > 0 && (vs->ePolicy_setting_p != NULL && vs->ePolicy_setting_p->have_socket_script)) { + + int move_atcp_id = atcp_ePolicy_id_min + (atcpid - atcp_L4_id_min); + + if (curatcp < atcp_L4_id_min + (atcp_L4_nthreads >> 2)) { + if (atcpid < atcp_L4_id_min + (atcp_L4_nthreads >> 2)) { + move_atcp_id += (atcp_L4_nthreads >> 2); + } + } else { + if (!(atcpid < atcp_L4_id_min + (atcp_L4_nthreads >> 2))) { + move_atcp_id -= (atcp_L4_nthreads >> 2); + } + } + + /* For debug */ +#if _SLB_EPOLICY_CONNECT_RBTREE_H_DEBUG_ + char ip_src_str[128]; + char ip_dst_str[128]; + int ip_flag = isipv6 ? AF_INET6 : AF_INET; + inet_ntop(ip_flag, &(iph->ip_src), ip_src_str, 128); + inet_ntop(ip_flag, &(iph->ip_dst), ip_dst_str, 128); + printf( + "VS_GET_TCP:: curatcp=%d -> %d, %s:%d to %s:%d\n", + curatcp, move_atcp_id, + ip_src_str, ntohs(tcph->th_sport), + ip_dst_str, ntohs(tcph->th_dport) + ); +#endif + return move_atcp_id; + } else { + slb_ePolicy_connect_node_t node = { + .next = NULL, + .prev = NULL, + .is_ipv6 = isipv6, + .protocol = IPPROTO_TCP, + .local_port = ntohs(tcph->th_dport), + .remote_port = ntohs(tcph->th_sport), + }; + + if (isipv6) { + memcpy(&node.local_ip.ip6, &ip6->ip6_dst, sizeof(struct in6_addr)); + memcpy(&node.remote_ip.ip6, &ip6->ip6_src, sizeof(struct in6_addr)); + } else { + node.local_ip.ip4.s_addr = iph->ip_dst.s_addr; + node.remote_ip.ip4.s_addr = iph->ip_src.s_addr; + } + + slb_ePolicy_connect_node_init_key(&node); + + int move_atcp_id = atcp_ePolicy_id_min + (atcpid - atcp_L4_id_min); + + if (curatcp < atcp_L4_id_min + (atcp_L4_nthreads >> 2)) { + if (atcpid < atcp_L4_id_min + (atcp_L4_nthreads >> 2)) { + move_atcp_id += (atcp_L4_nthreads >> 2); + } + } else { + if (!(atcpid < atcp_L4_id_min + (atcp_L4_nthreads >> 2))) { + move_atcp_id -= (atcp_L4_nthreads >> 2); + } + } + + int search_flag = slb_ePolicy_connect_node_find(get_slb_ePolicy_tree_root(move_atcp_id), &node) == NULL? 0: 1; + + if (search_flag) { + /* For debug */ +#if _SLB_EPOLICY_CONNECT_RBTREE_H_DEBUG_ + char ip_src_str[128]; + char ip_dst_str[128]; + int ip_flag = isipv6 ? AF_INET6 : AF_INET; + inet_ntop(ip_flag, &(iph->ip_src), ip_src_str, 128); + inet_ntop(ip_flag, &(iph->ip_dst), ip_dst_str, 128); + printf( + "RS_GET_TCP:: curatcp=%d -> %d, %s:%d to %s:%d\n", + curatcp, move_atcp_id, + ip_src_str, ntohs(tcph->th_sport), + ip_dst_str, ntohs(tcph->th_dport) + ); +#endif + return move_atcp_id; + } + } + + return atcpid; +} + +#endif \ No newline at end of file Index: /branches/rel_apv_10_7_2_5_irule/usr/src/sys/click/app/slb/slb_vs_policy_kern.c =================================================================== --- /branches/rel_apv_10_7_2_5_irule/usr/src/sys/click/app/slb/slb_vs_policy_kern.c (revision 38731) +++ /branches/rel_apv_10_7_2_5_irule/usr/src/sys/click/app/slb/slb_vs_policy_kern.c (working copy) @@ -27335,6 +27335,10 @@ } /*ePolicy*/ + +/* Check if any socket functions are used. */ +extern void ePolicy_check_socket_script(ePolicy_vs_setting *ePolicy_p); + int ePolicy_attach_vs_script_kern(void *pcb, char *vs_name, char *script_name){ int lenth, i, j; @@ -27412,6 +27416,10 @@ break; } } + + /* Check if any socket functions are used. */ + ePolicy_check_socket_script(ePolicy_p); + update_conn_data2_status(); return 0; } @@ -27455,6 +27463,10 @@ vs_p->ext_app = slb_ssl_app[vs_p->slb_proto]; epolicy_enabled--; } + + /* Check if any socket functions are used. */ + ePolicy_check_socket_script(ePolicy_p); + update_conn_data2_status(); return 0; } @@ -27763,6 +27775,9 @@ slb_vs_table[i].ePolicy_setting_p = NULL; slb_vs_table[i].uproxy_app = UPROXY_APP_HTTP; slb_vs_table[i].is_attach_script = 0; + } else { + /* Check if any socket functions are used. */ + ePolicy_check_socket_script(slb_vs_table[i].ePolicy_setting_p); } break; } Index: /branches/rel_apv_10_7_2_5_irule/usr/src/sys/click/kern/click_queue.c =================================================================== --- /branches/rel_apv_10_7_2_5_irule/usr/src/sys/click/kern/click_queue.c (revision 38731) +++ /branches/rel_apv_10_7_2_5_irule/usr/src/sys/click/kern/click_queue.c (working copy) @@ -336,8 +336,18 @@ panic("%s: no memory for ATCP%d threads\n", __func__, i + atcp_tq_id_min); } - error = kthread_add(atcp_corethread_func, atcp_tqp_array[i], NULL, threads, RFSTOPPED, - 0, "atcp%d", i + atcp_tq_id_min); + /* + * The first half consists of the original ATCP L4 threads, + * while the second half comprises the newly added ePolicy threads. + */ + if (i >= atcp_tq_nthreads / 2) { + error = kthread_add(atcp_corethread_func, atcp_tqp_array[i], NULL, threads, RFSTOPPED, + 0, "atcp(ePolicy)%d", i + atcp_tq_id_min - (atcp_tq_nthreads / 2)); + } else { + error = kthread_add(atcp_corethread_func, atcp_tqp_array[i], NULL, threads, RFSTOPPED, + 0, "atcp%d", i + atcp_tq_id_min); + } + if (error) { panic("%s: kthread_create ATCP%d error(%d)", __func__, i + atcp_tq_id_min, error); @@ -436,7 +446,7 @@ int num; if (getenv_int(nic_nameunit, &test_tqid) && - 0 <= test_tqid && test_tqid < atcp_tq_nthreads) { + 0 <= test_tqid && test_tqid < (atcp_tq_nthreads >> 1)) { atcpid = test_tqid + atcp_tq_id_min; num = atcp_nic_bind_info[atcpid].num++; atcp_nic_bind_info[atcpid].nameunit[num] = nic_nameunit; @@ -444,17 +454,17 @@ return(test_tqid); } - if (vm_ndomains > 1 && atcp_tq_nthreads == mp_ncpus) { - atcpid = nic_unit % (atcp_tq_nthreads / 2); - atcpid += domain_id * atcp_tq_nthreads / 2 + atcp_tq_id_min; + if (vm_ndomains > 1 && (atcp_tq_nthreads >> 1) == mp_ncpus) { + atcpid = nic_unit % ((atcp_tq_nthreads >> 1) / 2); + atcpid += domain_id * (atcp_tq_nthreads >> 1) / 2 + atcp_tq_id_min; } else { - atcpid = nic_unit % atcp_tq_nthreads + atcp_tq_id_min; + atcpid = nic_unit % (atcp_tq_nthreads >> 1) + atcp_tq_id_min; } num = atcp_nic_bind_info[atcpid].num++; atcp_nic_bind_info[atcpid].nameunit[num] = nic_nameunit; atcp_nic_bind_info[atcpid].queueid[num] = -1; - return(nic_unit % atcp_tq_nthreads); + return(nic_unit % (atcp_tq_nthreads >> 1)); } int atcp_taskqueue_nic_mq_topo(const char *nic_nameunit, int nic_unit, @@ -468,7 +478,7 @@ snprintf(nic_conf, 64, "%s_%s%d", nic_nameunit, queue_name, queue_id); if (getenv_int(nic_conf, &test_tqid) && - 0 <= test_tqid && test_tqid < atcp_tq_nthreads) { + 0 <= test_tqid && test_tqid < (atcp_tq_nthreads >> 1)) { printf("===%s-%d atcp%d\n", nic_nameunit, queue_id, test_tqid); atcpid = test_tqid + atcp_tq_id_min; @@ -480,12 +490,12 @@ } if (vm_ndomains > 1) { - test_tqid = ((nic_unit * num_queues + queue_id) % (atcp_tq_nthreads / 2)); - test_tqid += domain_id * atcp_tq_nthreads / 2; + test_tqid = ((nic_unit * num_queues + queue_id) % ((atcp_tq_nthreads >> 1) / 2)); + test_tqid += domain_id * (atcp_tq_nthreads >> 1) / 2; printf("---%s-%d atcp%d\n", nic_nameunit, queue_id, test_tqid); atcpid = test_tqid + atcp_tq_id_min; } else { - test_tqid = ((nic_unit * num_queues + queue_id) % atcp_tq_nthreads); + test_tqid = ((nic_unit * num_queues + queue_id) % (atcp_tq_nthreads >> 1)); printf("---%s-%d atcp%d\n", nic_nameunit, queue_id, test_tqid); atcpid = test_tqid + atcp_tq_id_min; } Index: /branches/rel_apv_10_7_2_5_irule/usr/src/sys/click/net/click_ether.c =================================================================== --- /branches/rel_apv_10_7_2_5_irule/usr/src/sys/click/net/click_ether.c (revision 38731) +++ /branches/rel_apv_10_7_2_5_irule/usr/src/sys/click/net/click_ether.c (working copy) @@ -59,6 +59,7 @@ #include /* Bug 20494 (PPTP NAT), chengfei, 20090203*/ #include #include +#include #include #include #include @@ -2131,8 +2132,9 @@ return CLICKTCP_OUR_PACKET; } +/* Half of the total will retain the original ATCP L4 thread count. */ #define DISPATCHER_ALGORITHM1(num1, num2, n, offset) \ - ((atcp_L4_nthreads_mask) ? (((num1) + (num2)) & atcp_L4_nthreads_mask) + (offset) : ( (((num1)+(num2)) % (n)) + (offset) )) + ((atcp_L4_nthreads_mask >> 1) ? (((num1) + (num2)) & (atcp_L4_nthreads_mask >> 1)) + (offset) : ( (((num1)+(num2)) % (n >> 1)) + (offset) )) /* ATCP dispatcher algorithm */ static __inline uint32_t atcp_dispatcher_algorithm1(u_short sport, u_short dport) { @@ -2613,6 +2615,12 @@ } } else { atcpid = atcp_dispatcher_algorithm1(ntohs(tcph->th_sport),ntohs(tcph->th_dport)); + /* + * Check the mbuf; if it is a corresponding VS and the ePolicy script is set + * or it is an RS packet recorded in the hash table, + * dispatch the packet to the dedicated ePolicy thread. + */ + atcpid = slb_ePolicy_connect_tcp_mbuf_thread_dispatcher(atcpid, m, tcph, isipv6); } } #if 0 @@ -2892,6 +2900,12 @@ atcpid = atcp_management_id; } else { atcpid = atcp_dispatcher_algorithm1(ntohs(tcph->th_sport), ntohs(tcph->th_dport)); + /* + * Check the mbuf; if it is a corresponding VS and the ePolicy script is set + * or it is an RS packet recorded in the hash table, + * dispatch the packet to the dedicated ePolicy thread. + */ + atcpid = slb_ePolicy_connect_tcp_mbuf_thread_dispatcher(atcpid, m, tcph, isipv6); } } else if (IPPROTO_UDP == ip_p) { if(isipv6) { Index: /branches/rel_apv_10_7_2_5_irule/usr/src/sys/click/netinet/click_input.c =================================================================== --- /branches/rel_apv_10_7_2_5_irule/usr/src/sys/click/netinet/click_input.c (revision 38731) +++ /branches/rel_apv_10_7_2_5_irule/usr/src/sys/click/netinet/click_input.c (working copy) @@ -147,6 +147,7 @@ #include #include #include /*bug 17186, kouhb, 20070917*/ +#include #include #include #include @@ -1004,6 +1005,7 @@ SYSCTL_ULONG(_kern,OID_AUTO ,clickosmonitor, CTLFLAG_RD, &clickosmonitor_p , 0, "monitor cpu and fan ,power pointer"); +struct slb_ePolicy_connect_node_tree *slb_ePolicy_connect_tree[ATCP_MAXTHREADS]; struct atcp_adapter *atcp_adapter_array[ATCP_MAXTHREADS] __cacheline_aligned = {0}; void *atcpwait[ATCP_MAXTHREADS] = {0}; @@ -2020,6 +2022,12 @@ thread_unlock(curthread); /* record which core this atcp is running on, this */ /* is needed because atcp n may be bound to core m */ + } else { + test_cpuid = curatcp - atcp_ePolicy_id_min; + + thread_lock(curthread); + sched_bind(curthread, test_cpuid); + thread_unlock(curthread); } if (atcp_management_id==curatcp ||atcp_IP_id==curatcp) { thread_lock(curthread); @@ -2028,6 +2036,13 @@ } TD_SET_RUNNING(curthread); + /* Initialize the hash table and read-write lock for each ePolicy thread. */ + if (curatcp >= atcp_L4_id_min) { + cur_slb_ePolicy_tree_root = + (struct slb_ePolicy_connect_node_tree *)malloc(sizeof(struct slb_ePolicy_connect_node_tree), M_TEMP, M_NOWAIT); + RB_INIT(cur_slb_ePolicy_tree_root); + } + /* atcp_adapter->atcp_clicktcpintrq initialization */ char ring_name[64]; sprintf(ring_name, "atcp%d_input_queue%d_mp", curatcp, 0); @@ -2780,6 +2795,19 @@ priority = atcp_prio_manage_ip; snprintf(td_name, MAXCOMLEN, "atcp%d: IP", i); } + /* The special ATCP thread for ePolicy */ + else if ((atcp_ePolicy_id_min <= i) && (i <= atcp_ePolicy_id_max)) { + if (!atcp_L4_tq_int) { + error = kthread_add(clicktcp_kthread_func, atcpwait[i], + NULL, &td, RFSTOPPED, 0, "atcp%d", i); + snprintf(td_name, MAXCOMLEN, "atcp%d: L4(ePolicy)", i); + } else { + /* Complete taskqueue ATCP initialization in atcp_taskqueue_create */ + atcp_adapter_array[i]->atcp_td = taskqueue_td0(atcp_tqp_array[i - atcp_tq_id_min]); + continue; + } + priority = atcp_prio; + } /* L4 thread */ else if ((atcp_L4_id_min <= i) && (i <= atcp_L4_id_max)){ if (!atcp_L4_tq_int) { @@ -11756,6 +11784,9 @@ clicktcp_enter_func(pcb, m); + /* When the RS connection is closed, remove it from the hash table. */ + slb_ePolicy_connect_table_rm_node(pcb); + /*Validate before setting RECVFIN flag*/ /*pcb->cp_flags |= CLICKPCB_RECVFIN;*/ @@ -11791,6 +11822,9 @@ clicktcp_enter_func(pcb, m); + /* When the RS connection is closed, remove it from the hash table. */ + slb_ePolicy_connect_table_rm_node(pcb); + /* do normal ack handling as well */ retval = clicktcp_handle_ack(pcb, m, isipv6, iph, tcp, datalen); @@ -11869,6 +11903,9 @@ clicktcp_enter_func(pcb, m); + /* When the RS connection is closed, remove it from the hash table. */ + slb_ePolicy_connect_table_rm_node(pcb); + /* * Fast path -- * @@ -11969,7 +12006,10 @@ if (pcb->cp_flags & CLICKPCB_ACTIVE_OPEN) { clicktcp_disable_listen_port(IPPROTO_TCP, pcb->cp_remoteport, PT_RS); } - + + /* When the RS connection is closed, remove it from the hash table. */ + slb_ePolicy_connect_table_rm_node(pcb); + clicktcp_close_slb_conn(pcb); clicktcp_cleanup_pcb(pcb); clickpcb_delete(pcb); @@ -11990,6 +12030,9 @@ clicktcp_enter_func(pcb, m); + /* When the RS connection is closed, remove it from the hash table. */ + slb_ePolicy_connect_table_rm_node(pcb); + if (tcp->th_seq+datalen+1 != pcb->recvnextseq) { tcplog(pcb, CTCPLOG_DEBUG, "got FIN in passclose_fin() which isn't a retransmit (%u != %u)\n", @@ -17425,6 +17468,8 @@ clicktcp_disable_listen_port(IPPROTO_TCP, pcb->cp_remoteport, PT_RS); } + /* When the RS connection is closed, remove it from the hash table. */ + slb_ePolicy_connect_table_rm_node(pcb); clicktcp_close_slb_conn(pcb); clicktcp_cleanup_pcb(pcb); @@ -17487,6 +17532,9 @@ clicktcp_disable_listen_port(IPPROTO_TCP, pcb->cp_remoteport, PT_RS); } + /* When the RS connection is closed, remove it from the hash table. */ + slb_ePolicy_connect_table_rm_node(pcb); + clicktcp_close_slb_conn(pcb); clicktcp_cleanup_pcb(pcb); clickpcb_delete(pcb); Index: /branches/rel_apv_10_7_2_5_irule/usr/src/sys/sys/smp.h =================================================================== --- /branches/rel_apv_10_7_2_5_irule/usr/src/sys/sys/smp.h (revision 38731) +++ /branches/rel_apv_10_7_2_5_irule/usr/src/sys/sys/smp.h (working copy) @@ -130,6 +130,9 @@ extern uint32_t atcp_L4_nthreads; extern uint32_t atcp_L4_nthreads_mask; +extern uint32_t atcp_ePolicy_id_min; +extern uint32_t atcp_ePolicy_id_max; + extern uint32_t atcp_L7_id; extern uint32_t atcp_tq_id_min;