rendered paste bodydiff --git a/kadr.pl b/kadr.plindex a1854c2..bb19a35 100644--- a/kadr.pl+++ b/kadr.pl@@ -20,6 +20,7 @@ use File::Find; use Getopt::Long; use Digest::MD4; use db;+use Encode; # TODO: convert all this to a single hash # TODO: allow loading settings from a config file@@ -59,6 +60,374 @@ GetOptions( "purge-old-db-entries!" => \$purge_old_db_entries, # Debug option. Default = true. false disables deletion of old cached records. ); +### Windows Unicode support wrappers+if ($^O =~ /MSWin/) {++ ### NOTE: ALL file manipulation files defined here *ONLY WORK WITH ABSOLUTE PATHS*++ require Win32API::File; Win32API::File->import qw(:FuncW :Func :MOVEFILE_ :GENERIC_ :FILE_SHARE_ OPEN_EXISTING);+ require Win32::API; Win32::API->import;++ # Enable output of UTF-8 text++ my $GetStdHandle = Win32::API->new('kernel32.dll', 'GetStdHandle',+ 'I', 'I') or die "GetStdHandle: $^E";+ my $WriteConsoleW = Win32::API->new('kernel32.dll', 'WriteConsoleW',+ 'IPIPP', 'I') or die "WriteConsoleW: $^E";++ use constant STD_OUTPUT_HANDLE => 0xfffffff5;++ my $stdout = $GetStdHandle->Call(STD_OUTPUT_HANDLE);++ # Use Win32::API to load needed functions not defined by Win32API::File++ use constant ERROR_NO_MORE_FILES => 18;+ use constant INVALID_HANDLE_VALUE => -1;++ typedef Win32::API::Struct FILETIME => qw{+ DWORD dwLowDateTime;+ DWORD dwHighDateTime;+ }; # 8 bytes++ use constant FILE_ATTRIBUTE_READONLY => 0x00000001;+ use constant FILE_ATTRIBUTE_HIDDEN => 0x00000002;+ use constant FILE_ATTRIBUTE_SYSTEM => 0x00000004;+ use constant FILE_ATTRIBUTE_DIRECTORY => 0x00000010;+ use constant FILE_ATTRIBUTE_ARCHIVE => 0x00000020;+ use constant FILE_ATTRIBUTE_NORMAL => 0x00000080;+ use constant FILE_ATTRIBUTE_TEMPORARY => 0x00000100;+ use constant FILE_ATTRIBUTE_COMPRESSED => 0x00000800;+ use constant MAX_PATH => 260;++ typedef Win32::API::Struct WIN32_FIND_DATAW => qw{+ DWORD dwFileAttributes;+ FILETIME ftCreationTime;+ FILETIME ftLastAccessTime;+ FILETIME ftLastWriteTime;+ DWORD nFileSizeHigh;+ DWORD nFileSizeLow;+ DWORD dwReserved0;+ DWORD dwReserved1;+ WCHAR cFileName[520];+ WCHAR cAlternateFileName[28];+ }; # 4 + 8 x 3 + 4 x 4 + 520 + 28 = 592 bytes++ my $FindFirstFileW = Win32::API->new('kernel32.dll', 'FindFirstFileW',+ 'PS', 'N') or die "FindFirstFile: $^E";+ my $FindNextFileW = Win32::API->new('kernel32.dll', 'FindNextFileW',+ 'NS', 'I') or die "FindNextFile $^E";+ my $FindClose = Win32::API->new('kernel32.dll', 'FindClose',+ 'N', 'I') or die "FileClose $^E";++ typedef Win32::API::Struct SHFILEOPSTRUCT => qw{+ HWND hwnd;+ UINT wFunc;+ LPCTSTR pFrom;+ LPCTSTR pTo;+ WORD fFlags;+ BOOL fAnyOperationsAborted;+ LPVOID hNameMappings;+ LPCTSTR lpszProgressTitle;+ };++ my $SHFileOperationW = Win32::API->new('shell32.dll', 'SHFileOperationW',+ 'S', 'I') or die "SHFileOperation: $^E";+ + my $CreateDirectoryW = Win32::API->new('kernel32.dll',+ 'BOOL CreateDirectoryW(LPCWSTR lpPathName, LPVOID lpSecurityAttributes);') or die "CreateDirectoryW: $^E";++ my $enc = sub {+ my $str = shift;+ return encode("UTF-16LE", "$str\0");+ };++ *myprint = sub {+ my $str = shift;+ my $len = length($str);+ $str = $enc->($str);+ my $count = 0;+ return $count if $WriteConsoleW->Call($stdout, $str, $len, $count, []);+ return 0;+ };++ *mymove = sub {+ my ($src, $dest) = @_;+ $src =~ s/\//\\/g;+ $dest =~ s/\//\\/g;+ MoveFileExW($enc->("\\\\?\\$src"), $enc->("\\\\?\\$dest"), fileConstant("MOVEFILE_COPY_ALLOWED")|fileConstant("MOVEFILE_WRITE_THROUGH"));+ };+ + *mymkpath = sub {+ my $path = shift;+ my $p = $path;+ $p =~ s/\//\\/g;+ unless (myexists($path)) {+ $! = 0;+ unless ($CreateDirectoryW->Call($enc->("\\\\?\\$p"), undef)) {+ my $parent = $path;+ $parent =~ s/\/[^\/]*$//;+ if ($parent eq $path) {+ return undef;+ }+ unless (mymkpath($parent)) {+ return undef;+ }+ # Parent made, try again making the child+ unless ($CreateDirectoryW->Call($enc->("\\\\?\\$p"), undef)) {+ return undef;+ }+ }+ }+ return $path;+ };++ *myexists = sub {+ my $p = shift;+ $p =~ s/\//\\/g;+ return GetFileAttributesW($enc->("\\\\?\\$p")) != fileConstant("INVALID_FILE_ATTRIBUTES");+ };++ *mysize = sub {+ my $p = shift;+ $p =~ s/\//\\/g;+ my $handle = CreateFileW($enc->("\\\\?\\$p"), 0, fileConstant("FILE_SHARE_READ") |+ fileConstant("FILE_SHARE_WRITE"), [],+ fileConstant("OPEN_EXISTING"), 0, []);+ my $size = getFileSize($handle);+ CloseHandle($handle);+ return $size;+ };+ + *myunlink = sub {+ DeleteFileW($enc->(shift));+ };++ *clean_scan_dirs = sub {+ my $path = shift;+ my $remove_ok = shift;+ $remove_ok = 0 unless defined($remove_ok);+ my @subfolders = ();++ my $FileInfo = Win32::API::Struct->new('WIN32_FIND_DATAW');++ my $files = 0;+ + $path =~ s/[\/\\]$//; # The string cannot end with a \\ or /+ my $p = $path;+ $p =~ s/\//\\/g; # FindFirstFile doesn't like '/' :(++ # The \\?\ prefix is extra magic mode for long absolute paths+ my $handle = $FindFirstFileW->Call($enc->("\\\\?\\$p\\*"), $FileInfo);++ if ($handle == INVALID_HANDLE_VALUE) {+ myprint("Error on \\\\?\\$p\\*:\n");+ printf "Error is %d - %s\n", Win32::GetLastError (),+ Win32::FormatMessage (Win32::GetLastError ());+ exit(1);+ } else {+ my ($attrib, $filename);++ do {+ $attrib = $FileInfo->{dwFileAttributes};++ $filename = unpack("x44A520", $FileInfo->{buffer});+ $filename = decode("UTF-16LE", "$filename\0", 1);++ $FileInfo->{cFileName} = "\0" x (520 * 2); # Clear the filename++ unless($filename eq '.' or $filename eq '..' or $attrib & FILE_ATTRIBUTE_SYSTEM) {+ if ($attrib & FILE_ATTRIBUTE_DIRECTORY) {+ push @subfolders, "$path/$filename";+ } else {+ $files++;+ }+ }++ } while ($FindNextFileW->Call($handle, $FileInfo));++ $FindClose->Call($handle);+ }++ my $folders = @subfolders;+ for my $folder (@subfolders) {+ --$folders if clean_scan_dirs($folder, 1);+ }++ return 0 if (!$remove_ok or $files or $folders);++ my $SHFileOp = Win32::API::Struct->new('SHFILEOPSTRUCT');+ $SHFileOp->{wFunc} = 3; # FO_DELETE+ $SHFileOp->{pFrom} = $enc->("\\\\?\\" . $p) . "\0"; # Needs an extra \0+ $SHFileOp->{fFlags} = 16 | 4; # FOF_NOCONFIRMATION | FOF_SILENT++ $SHFileOperationW->Call($SHFileOp);+ return 1;+ };++ *recurse = sub {+ my @paths = @_;++ my @files = ();+ my $FileInfo = Win32::API::Struct->new('WIN32_FIND_DATAW');++ for my $path (@paths) {+ next if $path =~ /Incomplete/;+ $path =~ s/[\/\\]$//; # The string cannot end with a \\ or /+ my $p = $path;+ $p =~ s/\//\\/g; # FindFirstFile doesn't like '/' :(+ # The \\?\ prefix is extra magic mode for long absolute paths+ my $handle = $FindFirstFileW->Call($enc->("\\\\?\\$p\\*"), $FileInfo);++ if ($handle == INVALID_HANDLE_VALUE) {+ myprint("Error on \\\\?\\$p\\*:\n");+ printf "Error is %d - %s\n", Win32::GetLastError (),+ Win32::FormatMessage (Win32::GetLastError ());+ exit(1);+ } else {+ my ($attrib, $filename);++ do {+ $attrib = $FileInfo->{dwFileAttributes};++ $filename = unpack("x44A520", $FileInfo->{buffer});+ $filename = decode("UTF-16LE", "$filename\0", 1);++ $FileInfo->{cFileName} = "\0" x (520 * 2); # Clear the filename++ unless($filename eq '.' or $filename eq '..' or $attrib & FILE_ATTRIBUTE_SYSTEM) {+ if ($attrib & FILE_ATTRIBUTE_DIRECTORY) {+ push @paths, "$path/$filename";+ } else {+ push @files, "$path/$filename";+ }+ }++ } while ($FindNextFileW->Call($handle, $FileInfo));++ $FindClose->Call($handle);+ }+ }+ return @files;+ };+ + *calc_ed2k_hash = sub {+ my($file) = @_;+ my $ed2k;+ my $ctx = Digest::MD4->new;+ my $ctx2 = Digest::MD4->new;+ my $buffer;+ my $handle = CreateFileW($enc->($file), GENERIC_READ(), FILE_SHARE_READ(), [], OPEN_EXISTING(), 0, []);+ die $! unless $handle;+ my $block = 0;+ my $b = 0;+ my $length = 0;+ my $donelen= 0;+ my $size = getFileSize($handle);+ while(ReadFile($handle, $buffer, 102400, $length, []) and $length) {+ while($length < 102400) {+ my $missing = 102400 - $length;+ my ($missing_buffer, $missing_read);+ ReadFile($handle, $missing_buffer, $missing, $missing_read, []);+ $length += $missing_read;+ last unless $missing_read;+ $buffer .= $missing_buffer;+ }+ $ctx->add($buffer);+ $donelen += $length;+ unless($b++ % 10) {+ my $progress = $donelen * 100 / $size;+ printer($file, sprintf("Hashing %d%%", $progress), 0);+ }++ if($b == 95) {+ $ctx2->add($ctx->digest);+ $b = 0;+ $block++;+ }+ }+ CloseHandle($handle);+ printer($file, "Hashed", 1);+ return $ctx->hexdigest if $block == 0;+ return $ctx2->hexdigest if $b == 0;+ $ctx2->add($ctx->digest);+ return $ctx2->hexdigest;+ };++} else {+ $|++;+ *myprint = sub { print shift; };+ *mymove = sub { move(shift, shift); };+ *mymkpath = sub { mkpath(shift); };+ *myexists = sub { -e shift; };+ *mysize = sub { -s shift; };+ *myunlink = sub { unlink(shift); };+ *clean_scan_dirs = sub { shift; finddepth({wanted => sub{rmdir}, follow => 1}, $_) if -e; };+ *recurse = sub {+ my(@paths) = @_;+ my @files;+ for my $path (@paths) {+ opendir IMD, $path;+ for(readdir IMD) {+ if(!($_ eq '.' or $_ eq '..' or ($windows and $_ eq 'System Volume Information'))) {+ $_ = "$path/$_";+ if(-d $_) {+ push @paths, $_;+ } else {+ push @files, $_;+ }+ }+ }+ close IMD;+ }+ return @files;+ };+ + *calc_ed2k_hash = sub {+ my($file) = @_;+ my $ed2k;+ my $ctx = Digest::MD4->new;+ my $ctx2 = Digest::MD4->new;+ my $buffer;+ open my $handle, "<", $file or die $!;+ binmode $handle;++ my $block = 0;+ my $b = 0;+ my $length = 0;+ my $donelen= 0;+ my $size = mysize($file);+ while($length = read $handle, $buffer, 102400) {+ while($length < 102400) {+ my $missing = 102400 - $length;+ my $missing_buffer;+ my $missing_read = read $handle, $missing_buffer, $missing;+ $length += $missing_read;+ last if !$missing_read;+ $buffer .= $missing_buffer;+ }+ $ctx->add($buffer);+ $b++;+ $donelen += $length;+ if($b % (1024)) {+ my $progress = ($donelen / $size) * 100;+ printer($file, "Hashing " . substr($progress, 0, index($progress, '.') + 2) . "%", 0);+ }++ if($b == 95) {+ $ctx2->add($ctx->digest);+ $b = 0;+ $block++;+ }+ }+ close($handle);+ printer($file, "Hashed", 1);+ return $ctx->hexdigest if $block == 0;+ return $ctx2->hexdigest if $b == 0;+ $ctx2->add($ctx->digest);+ return $ctx2->hexdigest;+ };+}+ my $db = db->new("dbi:SQLite:$db_path"); if($purge_old_db_entries) {@@ -89,7 +458,7 @@ my @files; my @ed2k_of_processed_files; my $dirs_done = 1; foreach(@scan_dirs) {- next if !-e $_;+ next if !myexists($_); printer($_, "Scanning", 0, $dirs_done++, scalar(@scan_dirs)); @files = (@files, sort(recurse($_))); }@@ -131,37 +500,17 @@ STDOUT->printflush("\r" . ' ' x $last_msg_len . "\r"); if($clean_scan_dirs) { for(@scan_dirs) {- finddepth({wanted => sub{rmdir}, follow => 1}, $_) if -e;- }-}--sub recurse {- my(@paths) = @_;- my @files;- for my $path (@paths) {- opendir IMD, $path;- for(readdir IMD) {- if(!($_ eq '.' or $_ eq '..' or ($windows and $_ eq 'System Volume Information'))) {- $_ = "$path/$_";- if(-d $_) {- push @paths, $_;- } else {- push @files, $_;- }- }- }- close IMD;+ clean_scan_dirs($_); }- return @files; } sub process_file { my($file, $a) = @_;- return if(not -e $file);+ return if not myexists($file); printer($file, "Processing", 0); my $ed2k = ed2k_hash($file);- my $fileinfo = $a->file_query({ed2k => $ed2k, size => -s $file});+ my $fileinfo = $a->file_query({ed2k => $ed2k, size => mysize($file)}); if(!defined $fileinfo) { printer($file, "Ignored", 1);@@ -170,7 +519,7 @@ sub process_file { # Auto-add to mylist. my $mylistinfo = $a->mylist_file_by_fid($fileinfo->{fid});- if(!defined $mylistinfo) {+ if(not defined($mylistinfo)) { printer($file, "Adding", 0); if (my $lid = $a->mylistadd($fileinfo->{fid})) { $db->update("adbcache_file", {lid => $lid}, {fid => $fileinfo->{fid}});@@ -214,14 +563,14 @@ sub process_file { $newname =~ s/[\\\\:\*"><\|\?]/_/g if $windows; unless($file eq "$file_output_dir/$newname") {- if(-e "$file_output_dir/$newname") {+ if(myexists("$file_output_dir/$newname")) { print "\nRename from: $file\nFailed to: $file_output_dir/$newname\n"; } else { printer($file, "File", 1); if($move) { printer("$file_output_dir/$newname", "Moving to", 0);- $db->update("known_files", {filename => $newname}, {ed2k => $ed2k, size => -s $file});- move($file, "$file_output_dir/$newname");+ $db->update("known_files", {filename => $newname}, {ed2k => $ed2k, size => mysize($file)});+ mymove($file, "$file_output_dir/$newname"); printer("$file_output_dir/$newname", "Moved to", 1); } else { printer("$file_output_dir/$newname", "Would have moved to", 1);@@ -255,7 +604,7 @@ sub avdump { sub ed2k_hash { my($file) = @_; my $file_sn = substr($file, rindex($file, '/') + 1, length($file));- my $size = -s $file;+ my $size = mysize($file); my($ed2k, $avdumped); my $r = $db->fetch("known_files", ["ed2k", "avdumped"], {filename => $file_sn, size => $size}, 1, "array"); if(defined $r) {@@ -270,57 +619,12 @@ sub ed2k_hash { return $ed2k; } -sub calc_ed2k_hash {- my($file) = @_;- my $ed2k;- my $ctx = Digest::MD4->new;- my $ctx2 = Digest::MD4->new;- my $buffer;- open my $handle, "<", $file or die $!;- binmode $handle;-- my $block = 0;- my $b = 0;- my $length = 0;- my $donelen= 0;- my $size = -s $file;- while($length = read $handle, $buffer, 102400) {- while($length < 102400) {- my $missing = 102400 - $length;- my $missing_buffer;- my $missing_read = read $handle, $missing_buffer, $missing;- $length += $missing_read;- last if !$missing_read;- $buffer .= $missing_buffer;- }- $ctx->add($buffer);- $b++;- $donelen += $length;- if($b % 100) {- my $progress = ($donelen / $size) * 100;- printer($file, "Hashing " . substr($progress, 0, index($progress, '.') + 2) . "%", 0);- }-- if($b == 95) {- $ctx2->add($ctx->digest);- $b = 0;- $block++;- }- }- close($handle);- printer($file, "Hashed", 1);- return $ctx->hexdigest if $block == 0;- return $ctx2->hexdigest if $b == 0;- $ctx2->add($ctx->digest);- return $ctx2->hexdigest;-}- sub printer { my($file, $status, $type, $progress, $total) = @_; my $status_len = length($status); $max_status_len = $status_len if $status_len > $max_status_len; my $msg = "[" . (defined $progress ? $progress : ($fcount - scalar(@files))) . "/" . (defined $total ? $total : $fcount) . "][$status]" . (" " x ($max_status_len - $status_len + 1)) . $file;- STDOUT->printflush(($last_msg_type ? "\n" : ("\r" . (length($msg) < $last_msg_len ? (' ' x $last_msg_len) . "\r" : ''))) . $msg);+ myprint(($last_msg_type ? "\n" : ("\r" . (length($msg) < $last_msg_len ? (' ' x $last_msg_len) . "\r" : ''))) . $msg); $last_msg_len = length($msg); $last_msg_type = $type; }@@ -648,6 +952,7 @@ sub _sendrecv { $vars->{'s'} = $self->{skey} if $self->{skey}; $vars->{'tag'} = "T" . $self->{queries}; $query .= ' ' . join('&', map { "$_=$vars->{$_}" } keys %{$vars}) . "\n";+ $query = encode_utf8($query); while(!$recvmsg) { if($self->{queries} > LONG_TERM_FLOODCONTROL_ENFORCEMENT_THRESHHOLD) {