Microsoft (R) Program Maintenance Utility Version 7.00.8882 Copyright (C) Microsoft Corp 1988-2000. All rights reserved. C:\cpanrun-5.8\build\5-8-0\bin\perl.exe "-MExtUtils::Command::MM" "-e" "test_harness(1, 'blib\lib', 'blib\arch')" t\01-use.t t\02-column-parse.t t\99-manifest.t t\99-pod.t t\99-todo.t t\99-unix-text.t t\99-versions.t t\01-use.............1..1 ok 1 - The object isa DBI::db ok t\02-column-parse....1..5 ok 1 - The object isa DBI::db ok 2 - Single asterisk ok 3 - Two columns ok 4 - Function (not implemented but gets passed through) ok 5 - Non-SELECT statement gets asterisk ok t\99-manifest........1..9 ok 1 - MANIFEST exists ok 2 - No empty lines in MANIFEST ok 3 - No whitespace-only lines in MANIFEST ok 4 - No trailing whitespace on lines in MANIFEST ok 5 - MANIFEST.skip exists ok 6 - No empty lines in MANIFEST.skip ok 7 - No whitespace-only lines in MANIFEST.skip ok 8 - No trailing whitespace on lines in MANIFEST.skip ok 9 - No test files left out of MANIFEST ok t\99-pod.............1..2 ok 1 - POD test for blib\lib/Win32/WQL.pm ok 2 - POD test for blib\lib/DBD/WMI.pm ok t\99-todo............1..2 ok 1 - Looking for XXXes in blib\lib/Win32/WQL.pm ok 2 - Looking for XXXes in blib\lib/DBD/WMI.pm ok t\99-unix-text.......1..2 # Failed test (t\99-unix-text.t at line 33) # got: '234' # expected: '0' not ok 1 - 'blib\lib/Win32/WQL.pm' contains no windows newlines # 0: package Win32::WQL; # 1: use strict; # 2: use Win32::OLE; # qw(EVENTS); # 3: # Events support will follow later # 4: use base 'Class::Accessor'; # 5: # 6: =head1 NAME # 7: # 8: Win32::WQL - DBI-like wrapper for the WMI # 9: # 10: =head1 SYNOPSIS # 11: # 12: use Win32::WQL; # 13: my $wmi = Win32::WQL->new( machine => 'remote_computer' ); # 14: my $sth = $wmi->prepare(<<'WQL'); # 15: # 16: ASSOCIATORS OF {Win32_Directory.Name='C:\\WINNT'} # 17: WHERE ResultClass = CIM_DataFile # 18: # 19: WQL # 20: # 21: my $remote_files = $sth->execute; # 22: while (my $file = $remote_files->fetch()) { # 23: print $file->{Name},"\n"; # 24: }; # 25: # 26: =head1 OVERVIEW # 27: # 28: This module implements a bare bones DBI clone # 29: which is similar yet different. You will most likely # 30: want to use the real thing, L, which # 31: is a compatibility layer over this module. # 32: # 33: =cut # 34: # 35: use vars qw($VERSION); # 36: $VERSION = '0.05'; # 37: # 38: Win32::OLE->Option(Warn => 3); # 39: # 40: __PACKAGE__->mk_accessors(qw(statement_class event_iterator_class collection_iterator_class wmi)); # 41: # 42: =head1 METHODS # 43: # 44: =head2 C<< new %ARGS >> # 45: # 46: Initializes the thin wrapper over the L # 47: WMI instance. All parameters are optional. # 48: # 49: machine # 50: # 51: The parameter is the machine name to connect to. It defaults # 52: to the local machine. # 53: # 54: wmi # 55: # 56: A preinitialized WMI object to use. Defaults to creating # 57: a fresh instance. # 58: # 59: statement_class # 60: # 61: The class into which the results of C # 62: are blessed. Defaults to C. # 63: # 64: event_iterator_class # 65: # 66: The class into which the results of C # 67: are blessed for event queries. Defaults to # 68: C. # 69: # 70: collection_iterator_class # 71: # 72: The class into which the results of C # 73: are blessed for static queries. Defaults to # 74: C. # 75: # 76: =cut # 77: # 78: sub new { # 79: my ($package, %args) = @_; # 80: my $machine = delete $args{machine} || '.'; # 81: my $self = { # 82: wmi => Win32::OLE->GetObject("winmgmts:\\\\$machine\\root\\cimV2"), # 83: statement_class => 'Win32::WQL::Statement', # 84: event_iterator_class => 'Win32::WQL::Iterator::Event', # 85: collection_iterator_class => 'Win32::WQL::Iterator::Collection', # 86: %args, # 87: }; # 88: $package->SUPER::new($self); # 89: }; # 90: # 91: =head2 C<< $wmi->prepare QUERY >> # 92: # 93: Returns a prepared query by calling # 94: # 95: return $self->statement_class->new({ # 96: query => $query, # 97: wmi => $self, # 98: iterator_class => $class, # 99: wmi_method => $method, # 100: }); # 101: # 102: =cut # 103: # 104: sub prepare { # 105: my ($self,$query) = @_; # 106: # 107: my ($class,$method,$fetch); # 108: if ($self->event_query($query)) { # 109: $class = $self->event_iterator_class; # 110: $method = 'ExecNotificationQuery'; # 111: } else { # 112: $class = $self->collection_iterator_class; # 113: $method = 'ExecQuery'; # 114: }; # 115: # 116: return $self->statement_class->new({ # 117: query => $query, # 118: wmi => $self, # 119: iterator_class => $class, # 120: wmi_method => $method, # 121: }); # 122: } # 123: # 124: =head2 C<< $wmi->event_query QUERY >> # 125: # 126: Determines whether a query is an event query # 127: or a static query. # 128: # 129: Event queries return a row whenever a new event # 130: arrives and block if there is no event available. # 131: # 132: Static queries are static and return all rows in # 133: one go. # 134: # 135: A query is considered an event query if it # 136: matches # 137: # 138: $query =~ /\b__instance(?:\w+)event\b/i # 139: or $query =~ /\wEvent\b/i # 140: # 141: =cut # 142: # 143: sub event_query { # 144: my ($package, $query) = @_; # 145: return # 146: ( $query =~ /\b__instance(?:\w+)event\b/i # 147: or $query =~ /\wEvent\b/i # 148: ) # 149: } # 150: # 151: package Win32::WQL::Statement; # 152: use strict; # 153: use Win32::OLE; # 154: use base 'Class::Accessor'; # 155: # 156: __PACKAGE__->mk_accessors(qw(iterator_class wmi query wmi_method)); # 157: # 158: sub execute { # 159: my ($self) = @_; # 160: my $m = $self->wmi_method; # 161: my $i = $self->wmi->wmi->$m( $self->query ); # 162: return $self->iterator_class->new({ # 163: wql_iterator => $i # 164: }); # 165: } # 166: # 167: package Win32::WQL::Iterator::Collection; # 168: use strict; # 169: use base 'Class::Accessor'; # 170: __PACKAGE__->mk_accessors(qw(wql_iterator items)); # 171: # 172: use Win32::OLE qw(in); # 173: use Data::Dumper; # 174: # 175: # Finite, prefetched list # 176: # 177: sub new { # 178: my ($package,$args) = @_; # 179: my @items = in delete $args->{wql_iterator}; # 180: $args->{items} = \@items; # 181: $package->SUPER::new($args); # 182: } # 183: # 184: sub fetchrow { # 185: my ($self) = @_; # 186: if (@{ $self->items }) { # 187: shift @{ $self->items }; # 188: } else { # 189: return () # 190: }; # 191: } # 192: # 193: package Win32::WQL::Iterator::Event; # 194: use strict; # 195: use base 'Class::Accessor'; # 196: __PACKAGE__->mk_accessors(qw(wql_iterator)); # 197: # 198: # potentially infinite list # 199: # 200: sub fetchrow { # 201: my ($self) = @_; # 202: return $self->wql_iterator->NextEvent(); # 203: } # 204: # 205: 1; # 206: # 207: =head1 SEE ALSO # 208: # 209: L for more examples # 210: # 211: =head1 TODO # 212: # 213: =over 4 # 214: # 215: =item * Implement parameters for and credentials # 216: # 217: =item * Implement a multiplexer by using multiple, waiting threads so you can C statements. # 156: All other statements get an implicit column # 157: of C<*>, meaning that the Win32::OLE objects # 158: will be returned. # 159: # 160: =cut # 161: # 162: sub parse_columns { # 163: my ($dbh, $statement) = @_; # 164: my @columns; # 165: if ($statement =~ /^\s*SELECT \s*(.*?)\s+FROM\b/mi) { # 166: @columns = map { s/^\s*//; s/\s*$//; $_ } split /,/, $1; # verrry simplicistic parsing # 167: } else { # 168: @columns = ('*'); # 169: }; # 170: # 171: \@columns # 172: }; # 173: # 174: sub STORE # 175: { # 176: my ($dbh, $attr, $val) = @_; # 177: if ($attr eq 'AutoCommit') { # 178: # AutoCommit is currently the only standard attribute we have # 179: # to consider. # 180: if (!$val) { die "Can't disable AutoCommit"; } # 181: return 1; # 182: } # 183: if ($attr =~ m/^wmi_/) { # 184: # Handle only our private attributes here # 185: # Note that we could trigger arbitrary actions. # 186: # Ideally we should warn about unknown attributes. # 187: $dbh->{$attr} = $val; # Yes, we are allowed to do this, # 188: return 1; # but only for our private attributes # 189: } # 190: # Else pass up to DBI to handle for us # 191: $dbh->SUPER::STORE($attr, $val); # 192: } # 193: # 194: sub FETCH # 195: { # 196: my ($dbh, $attr) = @_; # 197: if ($attr eq 'AutoCommit') { return 1; } # 198: if ($attr =~ m/^wmi_/) { # 199: # Handle only our private attributes here # 200: # Note that we could trigger arbitrary actions. # 201: return $dbh->{$attr}; # Yes, we are allowed to do this, # 202: # but only for our private attributes # 203: } # 204: # Else pass up to DBI to handle # 205: $dbh->SUPER::FETCH($attr); # 206: } # 207: # 208: package DBD::WMI::st; # 209: use strict; # 210: use Carp qw(croak); # 211: # 212: use vars qw($imp_data_size); # 213: # 214: $imp_data_size = 0; # 215: # 216: sub execute { # 217: my $sth = shift; # 218: # 219: # Recycle if we're still active # 220: $sth->finish if $sth->FETCH('Active'); # 221: # 222: my $params = (@_) ? # 223: \@_ : $sth->{wmi_params}; # 224: my $numParam = $sth->FETCH('NUM_OF_PARAMS'); # 225: return $sth->set_err(1, "Wrong number of parameters") # 226: if @$params != $numParam; # 227: if ($numParam > 0) { # 228: return $sth->set_err(1, "DBD::WMI doesn't support parameters yet") # 229: if @$params > 0; # 230: }; # 231: #my $statement = $sth->{'Statement'}; # 232: #for (my $i = 0; $i < $numParam; $i++) { # 233: # $statement =~ s/?/$params->[$i]/; # doesn't deal with quoting etc! # 234: # # 235: #}; # 236: # 237: my $iter = $sth->{wmi_sth}->execute(@$params); # 238: # 239: #$sth->STORE('Active',1); # 240: # 241: $sth->{'wmi_data'} = $iter; # 242: $sth->{'wmi_rows'} = 1; # we don't know/can't know # 243: $sth->STORE('NUM_OF_FIELDS', scalar @{$sth->FETCH('wmi_return_columns')});# $numFields; # 244: $sth->{'wmi_rows'} || '0E0'; # 245: } # 246: # 247: sub fetchrow_arrayref # 248: { # 249: my ($sth) = @_; # 250: my $data = $sth->{wmi_data}; # 251: my @row = $data->fetchrow(); # 252: # 253: if (! @row) { # 254: $sth->finish; # 255: return undef; # 256: } # 257: # 258: # Transform row objects into requested query columns # 259: if (my $columns = $sth->FETCH('wmi_return_columns')) { # 260: my $r = $row[0]; # 261: @row = map { $_ eq '*' ? $r : $r->{$_} } @$columns; # 262: }; # 263: # 264: if ($sth->FETCH('ChopBlanks')) { # 265: map { $_ =~ s/\s+$//; } @row; # 266: } # 267: return $sth->_set_fbav(\@row); # 268: } # 269: *fetch = \&fetchrow_arrayref; # required alias for fetchrow_arrayref # 270: # 271: sub STORE # 272: { # 273: my ($sth, $attr, $val) = @_; # 274: if ($attr =~ m/^wmi_/) { # 275: # Handle only our private attributes here # 276: # Note that we could trigger arbitrary actions. # 277: # Ideally we should warn about unknown attributes. # 278: $sth->{$attr} = $val; # Yes, we are allowed to do this, # 279: return 1; # but only for our private attributes # 280: } # 281: # Else pass up to DBI to handle for us # 282: $sth->SUPER::STORE($attr, $val); # 283: } # 284: # 285: sub FETCH # 286: { # 287: my ($sth, $attr) = @_; # 288: if ($attr eq 'AutoCommit') { return 1; } # 289: if ($attr =~ m/^wmi_/) { # 290: # Handle only our private attributes here # 291: # Note that we could trigger arbitrary actions. # 292: return $sth->{$attr}; # Yes, we are allowed to do this, # 293: # but only for our private attributes # 294: } # 295: # Else pass up to DBI to handle # 296: $sth->SUPER::FETCH($attr); # 297: } # 298: # 299: 1; # 300: # 301: =head1 HANDLING OF QUERY COLUMNS # 302: # 303: The WMI and WQL return full objects instead of single columns. The specification # 304: of columns is merely a hint to the object what properties to preload. The # 305: DBD interface deviates from that approach in that it returns objects # 306: for queries of the form C