1# 2# Copyright (c) 2003-2014, Ashok P. Nadkarni 3# All rights reserved. 4# 5# See the file LICENSE for license 6 7namespace eval twapi { 8} 9 10# 11# Return list of toplevel performance objects 12proc twapi::pdh_enumerate_objects {args} { 13 14 array set opts [parseargs args { 15 datasource.arg 16 machine.arg 17 {detail.arg wizard} 18 refresh 19 } -nulldefault] 20 21 # TBD - PdhEnumObjects enables the SeDebugPrivilege the first time it 22 # is called. Should we reset it if it was not already enabled? 23 # This seems to only happen on the first call 24 25 return [PdhEnumObjects $opts(datasource) $opts(machine) \ 26 [_perf_detail_sym_to_val $opts(detail)] \ 27 $opts(refresh)] 28} 29 30proc twapi::_pdh_enumerate_object_items_helper {selector objname args} { 31 array set opts [parseargs args { 32 datasource.arg 33 machine.arg 34 {detail.arg wizard} 35 refresh 36 } -nulldefault] 37 38 if {$opts(refresh)} { 39 _refresh_perf_objects $opts(machine) $opts(datasource) 40 } 41 42 return [PdhEnumObjectItems $opts(datasource) $opts(machine) \ 43 $objname \ 44 [_perf_detail_sym_to_val $opts(detail)] \ 45 $selector] 46} 47 48interp alias {} twapi::pdh_enumerate_object_items {} twapi::_pdh_enumerate_object_items_helper 0 49interp alias {} twapi::pdh_enumerate_object_counters {} twapi::_pdh_enumerate_object_items_helper 1 50interp alias {} twapi::pdh_enumerate_object_instances {} twapi::_pdh_enumerate_object_items_helper 2 51 52 53# 54# Construct a counter path 55proc twapi::pdh_counter_path {object counter args} { 56 array set opts [parseargs args { 57 machine.arg 58 instance.arg 59 parent.arg 60 {instanceindex.int -1} 61 {localized.bool false} 62 } -nulldefault] 63 64 if {$opts(instanceindex) == 0} { 65 # For XP. For first instance (index 0), the path should not contain 66 # "#0" but on XP it does. Reset it to -1 for Vista+ consistency 67 set opts(instanceindex) -1 68 } 69 70 71 if {! $opts(localized)} { 72 # Need to localize the counter names 73 set object [_pdh_localize $object] 74 set counter [_pdh_localize $counter] 75 # TBD - not sure we need to localize parent 76 set opts(parent) [_pdh_localize $opts(parent)] 77 } 78 79 # TBD - add options PDH_PATH_WBEM as documented in PdhMakeCounterPath 80 return [PdhMakeCounterPath $opts(machine) $object $opts(instance) \ 81 $opts(parent) $opts(instanceindex) $counter 0] 82 83} 84 85# 86# Parse a counter path and return the individual elements 87proc twapi::pdh_parse_counter_path {counter_path} { 88 return [twine {machine object instance parent instanceindex counter} [PdhParseCounterPath $counter_path 0]] 89} 90 91 92interp alias {} twapi::pdh_get_scalar {} twapi::_pdh_get 1 93interp alias {} twapi::pdh_get_array {} twapi::_pdh_get 0 94 95proc twapi::_pdh_get {scalar hcounter args} { 96 97 array set opts [parseargs args { 98 {format.arg large {long large double}} 99 {scale.arg {} {{} none x1000 nocap100}} 100 var.arg 101 } -ignoreunknown -nulldefault] 102 103 set flags [_pdh_fmt_sym_to_val $opts(format)] 104 105 if {$opts(scale) ne ""} { 106 set flags [expr {$flags | [_pdh_fmt_sym_to_val $opts(scale)]}] 107 } 108 109 set status 1 110 set result "" 111 trap { 112 if {$scalar} { 113 set result [PdhGetFormattedCounterValue $hcounter $flags] 114 } else { 115 set result [PdhGetFormattedCounterArray $hcounter $flags] 116 } 117 } onerror {TWAPI_WIN32 0x800007d1} { 118 # Error is that no such instance exists. 119 # If result is being returned in a variable, then 120 # we will not generate an error but pass back a return value 121 # of 0 122 if {[string length $opts(var)] == 0} { 123 rethrow 124 } 125 set status 0 126 } 127 128 if {[string length $opts(var)]} { 129 uplevel [list set $opts(var) $result] 130 return $status 131 } else { 132 return $result 133 } 134} 135 136# 137# Get the value of a counter identified by the path. 138# Should not be used to collect 139# rate based options. 140# TBD - document 141proc twapi::pdh_counter_path_value {counter_path args} { 142 143 array set opts [parseargs args { 144 {format.arg long} 145 scale.arg 146 datasource.arg 147 var.arg 148 full.bool 149 } -nulldefault] 150 151 # Open the query 152 set hquery [pdh_query_open -datasource $opts(datasource)] 153 trap { 154 set hcounter [pdh_add_counter $hquery $counter_path] 155 pdh_query_refresh $hquery 156 if {[string length $opts(var)]} { 157 # Need to pass up value in a variable if so requested 158 upvar $opts(var) myvar 159 set opts(var) myvar 160 } 161 set value [pdh_get_scalar $hcounter -format $opts(format) \ 162 -scale $opts(scale) -full $opts(full) \ 163 -var $opts(var)] 164 } finally { 165 pdh_query_close $hquery 166 } 167 168 return $value 169} 170 171 172# 173# Constructs one or more counter paths for getting process information. 174# Returned as a list of sublists. Each sublist corresponds to a counter path 175# and has the form {counteroptionname datatype counterpath rate} 176# datatype is the recommended format when retrieving counter value (eg. double) 177# rate is 0 or 1 depending on whether the counter is a rate based counter or 178# not (requires at least two readings when getting the value) 179proc twapi::get_perf_process_counter_paths {pids args} { 180 variable _process_counter_opt_map 181 182 if {![info exists _counter_opt_map]} { 183 # "descriptive string" format rate 184 array set _process_counter_opt_map { 185 privilegedutilization {"% Privileged Time" double 1} 186 processorutilization {"% Processor Time" double 1} 187 userutilization {"% User Time" double 1} 188 parent {"Creating Process ID" long 0} 189 elapsedtime {"Elapsed Time" large 0} 190 handlecount {"Handle Count" long 0} 191 pid {"ID Process" long 0} 192 iodatabytesrate {"IO Data Bytes/sec" large 1} 193 iodataopsrate {"IO Data Operations/sec" large 1} 194 iootherbytesrate {"IO Other Bytes/sec" large 1} 195 iootheropsrate {"IO Other Operations/sec" large 1} 196 ioreadbytesrate {"IO Read Bytes/sec" large 1} 197 ioreadopsrate {"IO Read Operations/sec" large 1} 198 iowritebytesrate {"IO Write Bytes/sec" large 1} 199 iowriteopsrate {"IO Write Operations/sec" large 1} 200 pagefaultrate {"Page Faults/sec" large 1} 201 pagefilebytes {"Page File Bytes" large 0} 202 pagefilebytespeak {"Page File Bytes Peak" large 0} 203 poolnonpagedbytes {"Pool Nonpaged Bytes" large 0} 204 poolpagedbytes {"Pool Paged Bytes" large 1} 205 basepriority {"Priority Base" large 1} 206 privatebytes {"Private Bytes" large 1} 207 threadcount {"Thread Count" large 1} 208 virtualbytes {"Virtual Bytes" large 1} 209 virtualbytespeak {"Virtual Bytes Peak" large 1} 210 workingset {"Working Set" large 1} 211 workingsetpeak {"Working Set Peak" large 1} 212 } 213 } 214 215 set optdefs { 216 machine.arg 217 datasource.arg 218 all 219 refresh 220 } 221 222 # Add counter names to option list 223 foreach cntr [array names _process_counter_opt_map] { 224 lappend optdefs $cntr 225 } 226 227 # Parse options 228 array set opts [parseargs args $optdefs -nulldefault] 229 230 # Force a refresh of object items 231 if {$opts(refresh)} { 232 # Silently ignore. The above counters are predefined and refreshing 233 # is just a time-consuming no-op. Keep the option for backward 234 # compatibility 235 if {0} { 236 _refresh_perf_objects $opts(machine) $opts(datasource) 237 } 238 } 239 240 # TBD - could we not use get_perf_instance_counter_paths instead of rest of this code 241 242 # Get the path to the process. 243 set pid_paths [get_perf_counter_paths \ 244 [_pdh_localize "Process"] \ 245 [list [_pdh_localize "ID Process"]] \ 246 $pids \ 247 -machine $opts(machine) -datasource $opts(datasource) \ 248 -all] 249 250 if {[llength $pid_paths] == 0} { 251 # No thread 252 return [list ] 253 } 254 255 # Construct the requested counter paths 256 set counter_paths [list ] 257 foreach {pid pid_path} $pid_paths { 258 259 # We have to filter out an entry for _Total which might be present 260 # if pid includes "0" 261 # TBD - does _Total need to be localized? 262 if {$pid == 0 && [string match -nocase *_Total\#0* $pid_path]} { 263 continue 264 } 265 266 # Break it down into components and store in array 267 array set path_components [pdh_parse_counter_path $pid_path] 268 269 # Construct counter paths for this pid 270 foreach {opt counter_info} [array get _process_counter_opt_map] { 271 if {$opts(all) || $opts($opt)} { 272 lappend counter_paths \ 273 [list -$opt $pid [lindex $counter_info 1] \ 274 [pdh_counter_path $path_components(object) \ 275 [_pdh_localize [lindex $counter_info 0]] \ 276 -localized true \ 277 -machine $path_components(machine) \ 278 -parent $path_components(parent) \ 279 -instance $path_components(instance) \ 280 -instanceindex $path_components(instanceindex)] \ 281 [lindex $counter_info 2] \ 282 ] 283 } 284 } 285 } 286 287 return $counter_paths 288} 289 290 291# Returns the counter path for the process with the given pid. This includes 292# the pid counter path element 293proc twapi::get_perf_process_id_path {pid args} { 294 return [get_unique_counter_path \ 295 [_pdh_localize "Process"] \ 296 [_pdh_localize "ID Process"] $pid] 297} 298 299 300# 301# Constructs one or more counter paths for getting thread information. 302# Returned as a list of sublists. Each sublist corresponds to a counter path 303# and has the form {counteroptionname datatype counterpath rate} 304# datatype is the recommended format when retrieving counter value (eg. double) 305# rate is 0 or 1 depending on whether the counter is a rate based counter or 306# not (requires at least two readings when getting the value) 307proc twapi::get_perf_thread_counter_paths {tids args} { 308 variable _thread_counter_opt_map 309 310 if {![info exists _thread_counter_opt_map]} { 311 array set _thread_counter_opt_map { 312 privilegedutilization {"% Privileged Time" double 1} 313 processorutilization {"% Processor Time" double 1} 314 userutilization {"% User Time" double 1} 315 contextswitchrate {"Context Switches/sec" long 1} 316 elapsedtime {"Elapsed Time" large 0} 317 pid {"ID Process" long 0} 318 tid {"ID Thread" long 0} 319 basepriority {"Priority Base" long 0} 320 priority {"Priority Current" long 0} 321 startaddress {"Start Address" large 0} 322 state {"Thread State" long 0} 323 waitreason {"Thread Wait Reason" long 0} 324 } 325 } 326 327 set optdefs { 328 machine.arg 329 datasource.arg 330 all 331 refresh 332 } 333 334 # Add counter names to option list 335 foreach cntr [array names _thread_counter_opt_map] { 336 lappend optdefs $cntr 337 } 338 339 # Parse options 340 array set opts [parseargs args $optdefs -nulldefault] 341 342 # Force a refresh of object items 343 if {$opts(refresh)} { 344 # Silently ignore. The above counters are predefined and refreshing 345 # is just a time-consuming no-op. Keep the option for backward 346 # compatibility 347 if {0} { 348 _refresh_perf_objects $opts(machine) $opts(datasource) 349 } 350 } 351 352 # TBD - could we not use get_perf_instance_counter_paths instead of rest of this code 353 354 # Get the path to the thread 355 set tid_paths [get_perf_counter_paths \ 356 [_pdh_localize "Thread"] \ 357 [list [_pdh_localize "ID Thread"]] \ 358 $tids \ 359 -machine $opts(machine) -datasource $opts(datasource) \ 360 -all] 361 362 if {[llength $tid_paths] == 0} { 363 # No thread 364 return [list ] 365 } 366 367 # Now construct the requested counter paths 368 set counter_paths [list ] 369 foreach {tid tid_path} $tid_paths { 370 # Break it down into components and store in array 371 array set path_components [pdh_parse_counter_path $tid_path] 372 foreach {opt counter_info} [array get _thread_counter_opt_map] { 373 if {$opts(all) || $opts($opt)} { 374 lappend counter_paths \ 375 [list -$opt $tid [lindex $counter_info 1] \ 376 [pdh_counter_path $path_components(object) \ 377 [_pdh_localize [lindex $counter_info 0]] \ 378 -localized true \ 379 -machine $path_components(machine) \ 380 -parent $path_components(parent) \ 381 -instance $path_components(instance) \ 382 -instanceindex $path_components(instanceindex)] \ 383 [lindex $counter_info 2] 384 ] 385 } 386 } 387 } 388 389 return $counter_paths 390} 391 392 393# Returns the counter path for the thread with the given tid. This includes 394# the tid counter path element 395proc twapi::get_perf_thread_id_path {tid args} { 396 397 return [get_unique_counter_path [_pdh_localize"Thread"] [_pdh_localize "ID Thread"] $tid] 398} 399 400 401# 402# Constructs one or more counter paths for getting processor information. 403# Returned as a list of sublists. Each sublist corresponds to a counter path 404# and has the form {counteroptionname datatype counterpath rate} 405# datatype is the recommended format when retrieving counter value (eg. double) 406# rate is 0 or 1 depending on whether the counter is a rate based counter or 407# not (requires at least two readings when getting the value) 408# $processor should be the processor number or "" to get total 409proc twapi::get_perf_processor_counter_paths {processor args} { 410 variable _processor_counter_opt_map 411 412 if {![string is integer -strict $processor]} { 413 if {[string length $processor]} { 414 error "Processor id must be an integer or null to retrieve information for all processors" 415 } 416 set processor "_Total" 417 } 418 419 if {![info exists _processor_counter_opt_map]} { 420 array set _processor_counter_opt_map { 421 dpcutilization {"% DPC Time" double 1} 422 interruptutilization {"% Interrupt Time" double 1} 423 privilegedutilization {"% Privileged Time" double 1} 424 processorutilization {"% Processor Time" double 1} 425 userutilization {"% User Time" double 1} 426 dpcrate {"DPC Rate" double 1} 427 dpcqueuerate {"DPCs Queued/sec" double 1} 428 interruptrate {"Interrupts/sec" double 1} 429 } 430 } 431 432 set optdefs { 433 machine.arg 434 datasource.arg 435 all 436 refresh 437 } 438 439 # Add counter names to option list 440 foreach cntr [array names _processor_counter_opt_map] { 441 lappend optdefs $cntr 442 } 443 444 # Parse options 445 array set opts [parseargs args $optdefs -nulldefault -maxleftover 0] 446 447 # Force a refresh of object items 448 if {$opts(refresh)} { 449 # Silently ignore. The above counters are predefined and refreshing 450 # is just a time-consuming no-op. Keep the option for backward 451 # compatibility 452 if {0} { 453 _refresh_perf_objects $opts(machine) $opts(datasource) 454 } 455 } 456 457 # Now construct the requested counter paths 458 set counter_paths [list ] 459 foreach {opt counter_info} [array get _processor_counter_opt_map] { 460 if {$opts(all) || $opts($opt)} { 461 lappend counter_paths \ 462 [list $opt $processor [lindex $counter_info 1] \ 463 [pdh_counter_path \ 464 [_pdh_localize "Processor"] \ 465 [_pdh_localize [lindex $counter_info 0]] \ 466 -localized true \ 467 -machine $opts(machine) \ 468 -instance $processor] \ 469 [lindex $counter_info 2] \ 470 ] 471 } 472 } 473 474 return $counter_paths 475} 476 477 478 479# 480# Returns a list comprising of the counter paths for counters with 481# names in the list $counters from those instance(s) whose counter 482# $key_counter matches the specified $key_counter_value 483proc twapi::get_perf_instance_counter_paths {object counters 484 key_counter key_counter_values 485 args} { 486 # Parse options 487 array set opts [parseargs args { 488 machine.arg 489 datasource.arg 490 {matchop.arg "exact"} 491 skiptotal.bool 492 refresh 493 } -nulldefault] 494 495 # Force a refresh of object items 496 if {$opts(refresh)} { 497 _refresh_perf_objects $opts(machine) $opts(datasource) 498 } 499 500 # Get the list of instances that have the specified value for the 501 # key counter 502 set instance_paths [get_perf_counter_paths $object \ 503 [list $key_counter] $key_counter_values \ 504 -machine $opts(machine) \ 505 -datasource $opts(datasource) \ 506 -matchop $opts(matchop) \ 507 -skiptotal $opts(skiptotal) \ 508 -all] 509 510 # Loop through all instance paths, and all counters to generate 511 # We store in an array to get rid of duplicates 512 array set counter_paths {} 513 foreach {key_counter_value instance_path} $instance_paths { 514 # Break it down into components and store in array 515 array set path_components [pdh_parse_counter_path $instance_path] 516 517 # Now construct the requested counter paths 518 # TBD - what should -localized be here ? 519 foreach counter $counters { 520 set counter_path \ 521 [pdh_counter_path $path_components(object) \ 522 $counter \ 523 -localized true \ 524 -machine $path_components(machine) \ 525 -parent $path_components(parent) \ 526 -instance $path_components(instance) \ 527 -instanceindex $path_components(instanceindex)] 528 set counter_paths($counter_path) "" 529 } 530 } 531 532 return [array names counter_paths] 533 534 535} 536 537 538# 539# Returns a list comprising of the counter paths for all counters 540# whose values match the specified criteria 541proc twapi::get_perf_counter_paths {object counters counter_values args} { 542 array set opts [parseargs args { 543 machine.arg 544 datasource.arg 545 {matchop.arg "exact"} 546 skiptotal.bool 547 all 548 refresh 549 } -nulldefault] 550 551 if {$opts(refresh)} { 552 _refresh_perf_objects $opts(machine) $opts(datasource) 553 } 554 555 set items [pdh_enum_object_items $object \ 556 -machine $opts(machine) \ 557 -datasource $opts(datasource)] 558 lassign $items object_counters object_instances 559 560 if {[llength $counters]} { 561 set object_counters $counters 562 } 563 set paths [_make_counter_path_list \ 564 $object $object_instances $object_counters \ 565 -skiptotal $opts(skiptotal) -machine $opts(machine)] 566 set result_paths [list ] 567 trap { 568 # Set up the query with the process id for all processes 569 set hquery [pdh_query_open -datasource $opts(datasource)] 570 foreach path $paths { 571 set hcounter [pdh_add_counter $hquery $path] 572 set lookup($hcounter) $path 573 } 574 575 # Now collect the info 576 pdh_query_refresh $hquery 577 578 # Now lookup each counter value to find a matching one 579 foreach hcounter [array names lookup] { 580 if {! [pdh_get_scalar $hcounter -var value]} { 581 # Counter or instance no longer exists 582 continue 583 } 584 585 set match_pos [lsearch -$opts(matchop) $counter_values $value] 586 if {$match_pos >= 0} { 587 lappend result_paths \ 588 [lindex $counter_values $match_pos] $lookup($hcounter) 589 if {! $opts(all)} { 590 break 591 } 592 } 593 } 594 } finally { 595 # TBD - should we have a catch to throw errors? 596 pdh_query_close $hquery 597 } 598 599 return $result_paths 600} 601 602 603# 604# Returns the counter path for counter $counter with a value $value 605# for object $object. Returns "" on no matches but exception if more than one 606proc twapi::get_unique_counter_path {object counter value args} { 607 set matches [get_perf_counter_paths $object [list $counter ] [list $value] {*}$args -all] 608 if {[llength $matches] > 1} { 609 error "Multiple counter paths found matching criteria object='$object' counter='$counter' value='$value" 610 } 611 return [lindex $matches 0] 612} 613 614 615 616# 617# Utilities 618# 619proc twapi::_refresh_perf_objects {machine datasource} { 620 pdh_enumerate_objects -refresh 621 return 622} 623 624 625# 626# Return the localized form of a counter name 627# TBD - assumes machine is local machine! 628proc twapi::_pdh_localize {name} { 629 variable _perf_counter_ids 630 variable _localized_perf_counter_names 631 632 set name_index [string tolower $name] 633 634 # If we already have a translation, return it 635 if {[info exists _localized_perf_counter_names($name_index)]} { 636 return $_localized_perf_counter_names($name_index) 637 } 638 639 # Didn't already have it. Go generate the mappings 640 641 # Get the list of counter names in English if we don't already have it 642 if {![info exists _perf_counter_ids]} { 643 foreach {id label} [registry get {HKEY_PERFORMANCE_DATA} {Counter 009}] { 644 set _perf_counter_ids([string tolower $label]) $id 645 } 646 } 647 648 # If we have do not have id for the given name, we will just use 649 # the passed name as the localized version 650 if {! [info exists _perf_counter_ids($name_index)]} { 651 # Does not seem to exist. Just set localized name to itself 652 return [set _localized_perf_counter_names($name_index) $name] 653 } 654 655 # We do have an id. THen try to get a translated name 656 if {[catch {PdhLookupPerfNameByIndex "" $_perf_counter_ids($name_index)} xname]} { 657 set _localized_perf_counter_names($name_index) $name 658 } else { 659 set _localized_perf_counter_names($name_index) $xname 660 } 661 662 return $_localized_perf_counter_names($name_index) 663} 664 665 666# Given a list of instances and counters, return a cross product of the 667# corresponding counter paths. 668# The list is expected to be already localized 669# Example: _make_counter_path_list "Process" (instance list) {{ID Process} {...}} 670# TBD - bug - does not handle -parent in counter path 671proc twapi::_make_counter_path_list {object instance_list counter_list args} { 672 array set opts [parseargs args { 673 machine.arg 674 skiptotal.bool 675 } -nulldefault] 676 677 array set instances {} 678 foreach instance $instance_list { 679 if {![info exists instances($instance)]} { 680 set instances($instance) 1 681 } else { 682 incr instances($instance) 683 } 684 } 685 686 if {$opts(skiptotal)} { 687 catch {array unset instances "*_Total"} 688 } 689 690 set counter_paths [list ] 691 foreach {instance count} [array get instances] { 692 while {$count} { 693 incr count -1 694 foreach counter $counter_list { 695 lappend counter_paths [pdh_counter_path \ 696 $object $counter \ 697 -localized true \ 698 -machine $opts(machine) \ 699 -instance $instance \ 700 -instanceindex $count] 701 } 702 } 703 } 704 705 return $counter_paths 706} 707 708 709# 710# Given a set of counter paths in the format returned by 711# get_perf_thread_counter_paths, get_perf_processor_counter_paths etc. 712# return the counter information as a flat list of field value pairs 713proc twapi::get_perf_values_from_metacounter_info {metacounters args} { 714 array set opts [parseargs args {{interval.int 100}}] 715 716 set result [list ] 717 set counters [list ] 718 if {[llength $metacounters]} { 719 set hquery [pdh_query_open] 720 trap { 721 set counter_info [list ] 722 set need_wait 0 723 foreach counter_elem $metacounters { 724 lassign $counter_elem pdh_opt key data_type counter_path wait 725 incr need_wait $wait 726 set hcounter [pdh_add_counter $hquery $counter_path] 727 lappend counters $hcounter 728 lappend counter_info $pdh_opt $key $counter_path $data_type $hcounter 729 } 730 731 pdh_query_refresh $hquery 732 if {$need_wait} { 733 after $opts(interval) 734 pdh_query_refresh $hquery 735 } 736 737 foreach {pdh_opt key counter_path data_type hcounter} $counter_info { 738 if {[pdh_get_scalar $hcounter -format $data_type -var value]} { 739 lappend result $pdh_opt $key $value 740 } 741 } 742 } onerror {} { 743 #puts "Error: $msg" 744 } finally { 745 pdh_query_close $hquery 746 } 747 } 748 749 return $result 750 751} 752 753proc twapi::pdh_query_open {args} { 754 variable _pdh_queries 755 756 array set opts [parseargs args { 757 datasource.arg 758 cookie.int 759 } -nulldefault] 760 761 set qh [PdhOpenQuery $opts(datasource) $opts(cookie)] 762 set id pdh[TwapiId] 763 dict set _pdh_queries($id) Qh $qh 764 dict set _pdh_queries($id) Counters {} 765 dict set _pdh_queries($id) Meta {} 766 return $id 767} 768 769proc twapi::pdh_query_refresh {qid args} { 770 variable _pdh_queries 771 _pdh_query_check $qid 772 PdhCollectQueryData [dict get $_pdh_queries($qid) Qh] 773 return 774} 775 776proc twapi::pdh_query_close {qid} { 777 variable _pdh_queries 778 _pdh_query_check $qid 779 780 dict for {ctrh -} [dict get $_pdh_queries($qid) Counters] { 781 PdhRemoveCounter $ctrh 782 } 783 784 PdhCloseQuery [dict get $_pdh_queries($qid) Qh] 785 unset _pdh_queries($qid) 786} 787 788proc twapi::pdh_add_counter {qid ctr_path args} { 789 variable _pdh_queries 790 791 _pdh_query_check $qid 792 793 parseargs args { 794 {format.arg large {long large double}} 795 {scale.arg {} {{} none x1000 nocap100}} 796 name.arg 797 cookie.int 798 array.bool 799 } -nulldefault -maxleftover 0 -setvars 800 801 if {$name eq ""} { 802 set name $ctr_path 803 } 804 805 if {[dict exists $_pdh_queries($qid) Meta $name]} { 806 error "A counter with name \"$name\" already present in the query." 807 } 808 809 set flags [_pdh_fmt_sym_to_val $format] 810 811 if {$scale ne ""} { 812 set flags [expr {$flags | [_pdh_fmt_sym_to_val $scale]}] 813 } 814 815 set hctr [PdhAddCounter [dict get $_pdh_queries($qid) Qh] $ctr_path $flags] 816 dict set _pdh_queries($qid) Counters $hctr 1 817 dict set _pdh_queries($qid) Meta $name [list Counter $hctr FmtFlags $flags Array $array] 818 819 return $hctr 820} 821 822proc twapi::pdh_remove_counter {qid ctrname} { 823 variable _pdh_queries 824 _pdh_query_check $qid 825 if {![dict exists $_pdh_queries($qid) Meta $ctrname]} { 826 badargs! "Counter \"$ctrname\" not present in query." 827 } 828 set hctr [dict get $_pdh_queries($qid) Meta $ctrname Counter] 829 dict unset _pdh_queries($qid) Counters $hctr 830 dict unset _pdh_queries($qid) Meta $ctrname 831 PdhRemoveCounter $hctr 832 return 833} 834 835proc twapi::pdh_query_get {qid args} { 836 variable _pdh_queries 837 838 _pdh_query_check $qid 839 840 # Refresh the data 841 PdhCollectQueryData [dict get $_pdh_queries($qid) Qh] 842 843 set meta [dict get $_pdh_queries($qid) Meta] 844 845 if {[llength $args] != 0} { 846 set names $args 847 } else { 848 set names [dict keys $meta] 849 } 850 851 set result {} 852 foreach name $names { 853 if {[dict get $meta $name Array]} { 854 lappend result $name [PdhGetFormattedCounterArray [dict get $meta $name Counter] [dict get $meta $name FmtFlags]] 855 } else { 856 lappend result $name [PdhGetFormattedCounterValue [dict get $meta $name Counter] [dict get $meta $name FmtFlags]] 857 } 858 } 859 860 return $result 861} 862 863twapi::proc* twapi::pdh_system_performance_query args { 864 variable _sysperf_defs 865 866 set _sysperf_defs { 867 event_count { {Objects Events} {} } 868 mutex_count { {Objects Mutexes} {} } 869 process_count { {Objects Processes} {} } 870 section_count { {Objects Sections} {} } 871 semaphore_count { {Objects Semaphores} {} } 872 thread_count { {Objects Threads} {} } 873 handle_count { {Process "Handle Count" -instance _Total} {-format long} } 874 commit_limit { {Memory "Commit Limit"} {} } 875 committed_bytes { {Memory "Committed Bytes"} {} } 876 committed_percent { {Memory "% Committed Bytes In Use"} {-format double} } 877 memory_free_mb { {Memory "Available MBytes"} {} } 878 memory_free_kb { {Memory "Available KBytes"} {} } 879 page_fault_rate { {Memory "Page Faults/sec"} {} } 880 page_input_rate { {Memory "Pages Input/sec"} {} } 881 page_output_rate { {Memory "Pages Output/sec"} {} } 882 883 disk_bytes_rate { {PhysicalDisk "Disk Bytes/sec" -instance _Total} {} } 884 disk_readbytes_rate { {PhysicalDisk "Disk Read Bytes/sec" -instance _Total} {} } 885 disk_writebytes_rate { {PhysicalDisk "Disk Write Bytes/sec" -instance _Total} {} } 886 disk_transfer_rate { {PhysicalDisk "Disk Transfers/sec" -instance _Total} {} } 887 disk_read_rate { {PhysicalDisk "Disk Reads/sec" -instance _Total} {} } 888 disk_write_rate { {PhysicalDisk "Disk Writes/sec" -instance _Total} {} } 889 disk_idle_percent { {PhysicalDisk "% Idle Time" -instance _Total} {-format double} } 890 } 891 892 # Per-processor counters are based on above but the object name depends 893 # on the system in order to support > 64 processors 894 set obj_name [expr {[min_os_version 6 1] ? "Processor Information" : "Processor"}] 895 dict for {key ctr_name} { 896 interrupt_utilization "% Interrupt Time" 897 privileged_utilization "% Privileged Time" 898 processor_utilization "% Processor Time" 899 user_utilization "% User Time" 900 idle_utilization "% Idle Time" 901 } { 902 lappend _sysperf_defs $key \ 903 [list \ 904 [list $obj_name $ctr_name -instance _Total] \ 905 [list -format double]] 906 907 lappend _sysperf_defs ${key}_per_cpu \ 908 [list \ 909 [list $obj_name $ctr_name -instance *] \ 910 [list -format double -array 1]] 911 } 912} { 913 variable _sysperf_defs 914 915 if {[llength $args] == 0} { 916 return [lsort -dictionary [dict keys $_sysperf_defs]] 917 } 918 919 set qid [pdh_query_open] 920 trap { 921 foreach arg $args { 922 set def [dict! $_sysperf_defs $arg] 923 set ctr_path [pdh_counter_path {*}[lindex $def 0]] 924 pdh_add_counter $qid $ctr_path -name $arg {*}[lindex $def 1] 925 } 926 pdh_query_refresh $qid 927 } onerror {} { 928 pdh_query_close $qid 929 rethrow 930 } 931 932 return $qid 933} 934 935# 936# Internal utility procedures 937proc twapi::_pdh_query_check {qid} { 938 variable _pdh_queries 939 940 if {![info exists _pdh_queries($qid)]} { 941 error "Invalid query id $qid" 942 } 943} 944 945proc twapi::_perf_detail_sym_to_val {sym} { 946 # PERF_DETAIL_NOVICE 100 947 # PERF_DETAIL_ADVANCED 200 948 # PERF_DETAIL_EXPERT 300 949 # PERF_DETAIL_WIZARD 400 950 # PERF_DETAIL_COSTLY 0x00010000 951 # PERF_DETAIL_STANDARD 0x0000FFFF 952 953 return [dict get {novice 100 advanced 200 expert 300 wizard 400 costly 0x00010000 standard 0x0000ffff } $sym] 954} 955 956 957proc twapi::_pdh_fmt_sym_to_val {sym} { 958 # PDH_FMT_RAW 0x00000010 959 # PDH_FMT_ANSI 0x00000020 960 # PDH_FMT_UNICODE 0x00000040 961 # PDH_FMT_LONG 0x00000100 962 # PDH_FMT_DOUBLE 0x00000200 963 # PDH_FMT_LARGE 0x00000400 964 # PDH_FMT_NOSCALE 0x00001000 965 # PDH_FMT_1000 0x00002000 966 # PDH_FMT_NODATA 0x00004000 967 # PDH_FMT_NOCAP100 0x00008000 968 969 return [dict get { 970 raw 0x00000010 971 ansi 0x00000020 972 unicode 0x00000040 973 long 0x00000100 974 double 0x00000200 975 large 0x00000400 976 noscale 0x00001000 977 none 0x00001000 978 1000 0x00002000 979 x1000 0x00002000 980 nodata 0x00004000 981 nocap100 0x00008000 982 nocap 0x00008000 983 } $sym] 984} 985