"Fossies" - the Fresh Open Source Software Archive 
Member "install-tl-20231127/tlpkg/TeXLive/TLWinGoo.pm" (20 Feb 2023, 38011 Bytes) of package /linux/misc/install-tl-unx.tar.gz:
As a special service "Fossies" has tried to format the requested source page into HTML format using (guessed) Perl source code syntax highlighting (style:
standard) with prefixed line numbers and
code folding option.
Alternatively you can here
view or
download the uninterpreted source code file.
1 # $Id: TLWinGoo.pm 65994 2023-02-20 23:40:00Z karl $
2 # TeXLive::TLWinGoo.pm - Windows goop.
3 # Copyright 2008-2023 Siep Kroonenberg, Norbert Preining
4 # This file is licensed under the GNU General Public License version 2
5 # or any later version.
6
7 # code for broadcast_env adapted from Win32::Env:
8 # Copyright 2006 Oleg "Rowaa[SR13]" V. Volkov, all rights reserved.
9 # This program is free software; you can redistribute it and/or modify it
10 # under the same terms as Perl itself.
11
12 #use strict; use warnings; notyet
13
14 package TeXLive::TLWinGoo;
15
16 my $svnrev = '$Revision: 65994 $';
17 my $_modulerevision;
18 if ($svnrev =~ m/: ([0-9]+) /) {
19 $_modulerevision = $1;
20 } else {
21 $_modulerevision = "unknown";
22 }
23 sub module_revision { return $_modulerevision; }
24
25 =pod
26
27 =head1 NAME
28
29 C<TeXLive::TLWinGoo> -- TeX Live Windows-specific support
30
31 =head2 SYNOPSIS
32
33 use TeXLive::TLWinGoo;
34
35 =head2 DIAGNOSTICS
36
37 TeXLive::TLWinGoo::is_ten;
38 TeXLive::TLWinGoo::admin;
39 TeXLive::TLWinGoo::non_admin;
40 TeXLive::TLWinGoo::reg_country;
41
42 =head2 ENVIRONMENT AND REGISTRY
43
44 TeXLive::TLWinGoo::expand_string($s);
45 TeXLive::TLWinGoo::get_system_path;
46 TeXLive::TLWinGoo::get_user_path;
47 TeXLive::TLWinGoo::setenv_reg($env_var, $env_data);
48 TeXLive::TLWinGoo::unsetenv_reg($env_var);
49 TeXLive::TLWinGoo::adjust_reg_path_for_texlive($action, $texbindir, $mode);
50 TeXLive::TLWinGoo::add_to_progids($ext, $filetype);
51 TeXLive::TLWinGoo::remove_from_progids($ext, $filetype);
52 TeXLive::TLWinGoo::register_extension($mode, $extension, $file_type);
53 TeXLive::TLWinGoo::unregister_extension($mode, $extension);
54 TeXLive::TLWinGoo::register_file_type($file_type, $command);
55 TeXLive::TLWinGoo::unregister_file_type($file_type);
56
57 =head2 ACTIVATING CHANGES IMMEDIATELY
58
59 TeXLive::TLWinGoo::broadcast_env;
60 TeXLive::TLWinGoo::update_assocs;
61
62 =head2 SHORTCUTS
63
64 TeXLive::TLWinGoo::desktop_path;
65 TeXLive::TLWinGoo::add_desktop_shortcut($texdir, $name, $icon,
66 $prog, $args, $batgui);
67 TeXLive::TLWinGoo::add_menu_shortcut($place, $name, $icon,
68 $prog, $args, $batgui);
69 TeXLive::TLWinGoo::remove_desktop_shortcut($name);
70 TeXLive::TLWinGoo::remove_menu_shortcut($place, $name);
71
72 =head2 UNINSTALLER
73
74 TeXLive::TLWinGoo::create_uninstaller;
75 TeXLive::TLWinGoo::unregister_uninstaller;
76
77 =head2 ADMIN: MAKE INSTALLATION DIRECTORIES READ-ONLY
78
79 TeXLive::TLWinGoo::maybe_make_ro($dir);
80
81 All exported functions return forward slashes.
82
83 =head1 DESCRIPTION
84
85 =over 4
86
87 =cut
88
89 BEGIN {
90 use Exporter;
91 use vars qw( @ISA @EXPORT @EXPORT_OK $Registry);
92 @ISA = qw( Exporter );
93 @EXPORT = qw(
94 &is_ten
95 &admin
96 &non_admin
97 );
98 @EXPORT_OK = qw(
99 &admin_again
100 ®_country
101 &broadcast_env
102 &update_assocs
103 &expand_string
104 &get_system_path
105 &get_user_path
106 &setenv_reg
107 &unsetenv_reg
108 &adjust_reg_path_for_texlive
109 &add_to_progids
110 &remove_from_progids
111 ®ister_extension
112 &unregister_extension
113 ®ister_file_type
114 &unregister_file_type
115 &shell_folder
116 &desktop_path
117 &add_desktop_shortcut
118 &add_menu_shortcut
119 &remove_desktop_shortcut
120 &remove_menu_shortcut
121 &create_uninstaller
122 &unregister_uninstaller
123 &maybe_make_ro
124 &get_system_env
125 &get_user_env
126 &is_a_texdir
127 &tex_dirs_on_path
128 );
129 if ($^O=~/^MSWin/i) {
130 require Win32;
131 require Win32::API;
132 require Win32API::File;
133 require File::Spec;
134 require Win32::TieRegistry;
135 Win32::TieRegistry->import( qw( $Registry
136 REG_SZ REG_EXPAND_SZ REG_NONE KEY_READ KEY_WRITE KEY_ALL_ACCESS
137 KEY_ENUMERATE_SUB_KEYS ) );
138 $Registry->Delimiter('/');
139 $Registry->ArrayValues(0);
140 $Registry->FixSzNulls(1);
141 require Win32::Shortcut;
142 Win32::Shortcut->import( qw( SW_SHOWNORMAL SW_SHOWMINNOACTIVE ) );
143 require Time::HiRes;
144 }
145 } # end BEGIN
146
147 use TeXLive::TLConfig;
148 use TeXLive::TLUtils;
149 TeXLive::TLUtils->import( qw( mkdirhier ) );
150
151 sub reg_debug {
152 return if ($::opt_verbosity < 1);
153 my $mess = shift;
154 my $regerr = Win32API::Registry::regLastError();
155 if ($regerr) {
156 debug("$regerr\n$mess");
157 }
158 }
159
160 my $is_win = ($^O =~ /^MSWin/i);
161
162 # Win32: import wrappers for some horrible API functions
163
164 # import failures return a null result;
165 # call imported functions only if true/non-null
166
167 my $SendMessage = 0;
168 my $update_fu = 0;
169 if ($is_win) {
170 $SendMessage = Win32::API::More->new('user32', 'SendMessageTimeout', 'LLPPLLP', 'L');
171 debug ("Import failure SendMessage\n") unless $SendMessage;
172 $update_fu = Win32::API::More->new('shell32', 'SHChangeNotify', 'LIPP', 'V');
173 debug ("Import failure assoc_notify\n") unless $update_fu;
174 }
175
176 =pod
177
178 =back
179
180 =head2 DIAGNOSTICS
181
182 =over 4
183
184 =item C<win_version>
185
186 C<win_version> returns the Windows version number as stored in the
187 registry: 5.0 for Windows 2000, 5.1 for Windows XP and 6.0 for Vista.
188
189 =cut
190
191 my $windows_version = 0;
192 my $windows_subversion = 0;
193
194 if ($is_win) {
195 my $ver = `ver`;
196 chomp $ver;
197 $ver =~ s/^[^0-9]*//;
198 $ver =~ s/[^0-9.]*$//;
199 ($windows_version = $ver) =~ s/\..*$//;
200 ($windows_subversion = $ver) =~ s/^[^\.]*\.//;
201 $windows_subversion =~ s/\..*$//;
202 }
203
204 =item C<is_ten>
205
206 C<is_ten> returns 1 if windows version is >= 10.0, otherwise 0.
207
208 =cut
209
210 sub is_ten { return $windows_version >= 10; }
211
212 # permissions with which we try to access the system environment
213
214 my $is_admin = 1;
215
216 if ($is_win) {
217 $is_admin = 0 unless Win32::IsAdminUser();
218 }
219
220 sub KEY_FULL_ACCESS() {
221 return KEY_WRITE() | KEY_READ();
222 }
223
224 sub sys_access_permissions {
225 return $is_admin ? KEY_FULL_ACCESS() : KEY_READ();
226 }
227
228 sub get_system_env {
229 return $Registry -> Open(
230 "LMachine/system/currentcontrolset/control/session manager/Environment/",
231 {Access => sys_access_permissions()});
232 }
233
234 sub get_user_env {
235 return $Registry -> Open("CUser/Environment", {Access => KEY_FULL_ACCESS()});
236 }
237
238 =pod
239
240 =item C<admin>
241
242 Returns admin status, admin implying having full read-write access
243 to the system environment.
244
245 =cut
246
247 # $is_admin has already got its correct value
248
249 sub admin { return $is_admin; }
250
251 =pod
252
253 =item C<non_admin>
254
255 Pretend not to have admin privileges, to enforce a user- rather than
256 a system install.
257
258 Currently only used for testing.
259
260 =cut
261
262 sub non_admin {
263 debug("TLWinGoo: switching to user mode\n");
264 $is_admin = 0;
265 }
266
267 # just for testing; doesn't check actual user permissions
268 sub admin_again {
269 debug("TLWinGoo: switching to admin mode\n");
270 $is_admin = 1;
271 }
272
273 =pod
274
275 =item C<reg_country>
276
277 Two-letter country code representing the locale of the current user
278
279 =cut
280
281 sub reg_country {
282 my $lm = cu_root()->{"Control Panel/international//localename"};
283 return unless $lm;
284 debug("found lang code lm = $lm...\n");
285 if ($lm) {
286 if ($lm =~ m/^zh-(tw|hk)$/i) {
287 return ("zh", "tw");
288 } elsif ($lm =~ m/^zh/) {
289 # for anything else starting with zh return, that is zh, zh-cn, zh-sg
290 # and maybe something else
291 return ("zh", "cn");
292 } else {
293 my $lang = lc(substr $lm, 0, 2);
294 my $area = lc(substr $lm, 3, 2);
295 return($lang, $area);
296 }
297 }
298 # otherwise undef will be returned
299 }
300
301
302 =pod
303
304 =back
305
306 =head2 ENVIRONMENT AND REGISTRY
307
308 Most settings can be made for a user and for the system. User
309 settings override system settings.
310
311 For admin users, the functions below affect both user- and system
312 settings. For non-admin users, only user settings are changed.
313
314 An exception is the search path: the effective searchpath consists
315 of the system searchpath in front concatenated with the user
316 searchpath at the back.
317
318 Note that in a roaming profile network setup, users take only user
319 settings with them to other systems, not system settings. In this
320 case, with a TeXLive on the network, a nonadmin install makes the
321 most sense.
322
323 =over 4
324
325 =item C<expand_string($s)>
326
327 This function replaces substrings C<%env_var%> with their current
328 values as environment variable and returns the result.
329
330 =cut
331
332 sub expand_string {
333 my ($s) = @_;
334 return Win32::ExpandEnvironmentStrings($s);
335 }
336
337 my $global_tmp = $is_win ? expand_string(get_system_env()->{'TEMP'}) : "/tmp";
338
339 sub is_a_texdir {
340 my $d = shift;
341 $d =~ s/\\/\//g;
342 $d = $d . '/' unless $d =~ m!/$!;
343 # don't consider anything under %systemroot% a texdir
344 my $sr = uc($ENV{'SystemRoot'});
345 $sr =~ s/\\/\//g;
346 $sr = $sr . '/' unless $sr =~ m!/$!;
347 return 0 if index($d, $sr)==0;
348 foreach my $p (qw(luatex.exe mktexlsr.exe pdftex.exe tex.exe xetex.exe)) {
349 return 1 if (-e $d.$p);
350 }
351 return 0;
352 }
353
354 =pod
355
356 =item C<get_system_path>
357
358 Returns unexpanded system path, as stored in the registry.
359
360 =cut
361
362 sub get_system_path {
363 my $value = get_system_env() -> {'/Path'};
364 # Remove terminating zero bytes; there may be several, at least
365 # under w2k, and the FixSzNulls option only removes one.
366 $value =~ s/[\s\x00]+$//;
367 return $value;
368 }
369
370 =pod
371
372 =item C<get_user_path>
373
374 Returns unexpanded user path, as stored in the registry. The user
375 path often does not exist, and is rarely expandable.
376
377 =cut
378
379 sub get_user_path {
380 my $value = get_user_env() -> {'/Path'};
381 return "" if not $value;
382 $value =~ s/[\s\x00]+$//;
383 return $value;
384 }
385
386 =pod
387
388 =item C<setenv_reg($env_var, $env_data[, $mode]);>
389
390 Set an environment variable $env_var to $env_data.
391
392 $mode="user": set for current user. $mode="system": set for all
393 users. Default: both if admin, current user otherwise.
394
395 =cut
396
397 sub setenv_reg {
398 my $env_var = shift;
399 my $env_data = shift;
400 my $mode = @_ ? shift : "default";
401 die "setenv_reg: Invalid mode $mode"
402 if ($mode ne "user" and $mode ne "system" and $mode ne "default");
403 die "setenv_reg: mode 'system' only available for admin"
404 if ($mode eq "system" and !$is_admin);
405 my $env;
406 if ($mode ne "system") {
407 $env = get_user_env();
408 $env->ArrayValues(1);
409 $env->{'/'.$env_var} =
410 [ $env_data, ($env_data =~ /%/) ? REG_EXPAND_SZ : REG_SZ ];
411 }
412 if ($mode ne "user" and $is_admin) {
413 $env = get_system_env();
414 $env->ArrayValues(1);
415 $env->{'/'.$env_var} =
416 [ $env_data, ($env_data =~ /%/) ? REG_EXPAND_SZ : REG_SZ ];
417 }
418 }
419
420 =pod
421
422 =item C<unsetenv_reg($env_var[, $mode]);>
423
424 Unset an environment variable $env_var
425
426 =cut
427
428 sub unsetenv_reg {
429 my $env_var = shift;
430 my $env = get_user_env();
431 my $mode = @_ ? shift : "default";
432 #print "Unsetenv_reg: unset $env_var with mode $mode\n";
433 die "unsetenv_reg: Invalid mode $mode"
434 if ($mode ne "user" and $mode ne "system" and $mode ne "default");
435 die "unsetenv_reg: mode 'system' only available for admin"
436 if ($mode eq "system" and !$is_admin);
437 delete get_user_env()->{'/'.$env_var} if $mode ne "system";
438 delete get_system_env()->{'/'.$env_var} if ($mode ne "user" and $is_admin);
439 }
440
441 =pod
442
443 =item C<tex_dirs_on_path($path)>
444
445 Returns tex directories found on the search path.
446 A directory is a TeX directory if it contains tex.exe or
447 pdftex.exe.
448
449 =cut
450
451 sub tex_dirs_on_path {
452 my ($path) = @_;
453 my ($d, $d_exp);
454 my @texdirs = ();
455 foreach $d (split (';', $path)) {
456 $d_exp = expand_string($d);
457 if (is_a_texdir($d_exp)) {
458 # tlwarn("Possibly conflicting [pdf]TeX program found at $d_exp\n");
459 push(@texdirs, $d_exp);
460 };
461 }
462 return @texdirs;
463 }
464
465 =pod
466
467 =item C<adjust_reg_path_for_texlive($action, $tlbindir, $mode)>
468
469 Edit system or user PATH variable in the registry.
470 Adds or removes (depending on $action) $tlbindir directory
471 to system or user PATH variable in the registry (depending on $mode).
472
473 =cut
474
475 # short path names should be unique
476
477 sub short_name {
478 my ($fname) = @_;
479 return $fname unless $is_win;
480 # GetShortPathName may return undefined, e.g. if $fname does not exist,
481 # e.g. because of temporary unavailability of a network- or portable drive,
482 # which should not be considered a real error
483 my $shname = Win32::GetShortPathName ($fname);
484 return (defined $shname) ? $shname : $fname;
485 }
486
487 sub adjust_reg_path_for_texlive {
488 my ($action, $tlbindir, $mode) = @_;
489 die("Unknown path action: $action\n")
490 if ($action ne 'add') && ($action ne 'remove');
491 die("Unknown path mode: $mode\n")
492 if ($mode ne 'system') && ($mode ne 'user');
493 debug("Warning: [pdf]tex program not found in $tlbindir\n")
494 if (!is_a_texdir($tlbindir));
495 my $path = ($mode eq 'system') ? get_system_path() : get_user_path();
496 $tlbindir =~ s!/!\\!g;
497 my $tlbindir_short = uc(short_name($tlbindir));
498 my ($d, $d_short, @newpath);
499 my $tex_dir_conflict = 0;
500 my @texdirs;
501 foreach $d (split (';', $path)) {
502 $d_short = uc(short_name(expand_string($d)));
503 $d_short =~ s!/!\\!g;
504 ddebug("adjust_reg: compare $d_short with $tlbindir_short\n");
505 if ($d_short ne $tlbindir_short) {
506 push(@newpath, $d);
507 if (is_a_texdir($d)) {
508 $tex_dir_conflict++;
509 push(@texdirs, $d);
510 }
511 }
512 }
513 if ($action eq 'add') {
514 if ($tex_dir_conflict) {
515 log("Warning: conflicting [pdf]tex program found on the $mode path ",
516 "in @texdirs; appending $tlbindir to the front of the path.\n");
517 unshift(@newpath, $tlbindir);
518 } else {
519 push(@newpath, $tlbindir);
520 }
521 }
522 if (@newpath) {
523 debug("TLWinGoo: adjust_reg_path_for_texlive: calling setenv_reg in $mode\n");
524 setenv_reg("Path", join(';', @newpath), $mode);
525 } else {
526 debug("TLWinGoo: adjust_reg_path_for_texlive: calling unsetenv_reg in $mode\n");
527 unsetenv_reg("Path", $mode);
528 }
529 if ( ($action eq 'add') && ($mode eq 'user') ) {
530 @texdirs = tex_dirs_on_path( get_system_path() );
531 return 0 unless (@texdirs);
532 tlwarn("Warning: conflicting [pdf]tex program found on the system path ",
533 "in @texdirs; not fixable in user mode.\n");
534 return 1;
535 }
536 return 0;
537 }
538
539 ### File types ###
540
541 # Refactored from 2010 edition. New functionality:
542 # add_to_progids for defining alternate filetypes for an extension.
543 # Their associated programs show up in the `open with' right-click menu.
544
545 ### helper subs ###
546
547 # merge recursive hash refs such as occur in the registry
548
549 sub hash_merge {
550 my $target = shift; # the recursive hash ref to be modified by $mods
551 my $mods = shift; # the recursive hash ref to be merged into $target
552 my $k;
553 foreach $k (keys %$mods) {
554 if (ref($target->{$k}) eq 'HASH' and ref($mods->{$k}) eq 'HASH') {
555 hash_merge($target->{$k}, $mods->{$k});
556 } else {
557 $target->{$k} = $mods->{$k};
558 reg_debug ("at hash merge\n");
559 $target->Flush();
560 reg_debug ("at hash merge\n");
561 }
562 }
563 }
564
565 # prevent catastrophies during testing; not to be used in production code
566
567 sub getans {
568 my $prompt = shift;
569 my $ans;
570 print STDERR "$prompt ";
571 $ans = <STDIN>;
572 if ($ans =~ /^y/i) {print STDERR "\n"; return 1;}
573 die "Aborting as requested";
574 }
575
576 # delete a registry key recursively.
577 # the key parameter should be a string, not a registry object.
578
579 sub reg_delete_recurse {
580 my $parent = shift;
581 my $childname = shift;
582 my $parentpath = $parent->Path;
583 ddebug("Deleting $parentpath$childname\n");
584 my $child;
585 if ($childname !~ '^/') { # subkey
586 $child = $parent->Open ($childname, {Access => KEY_FULL_ACCESS()});
587 reg_debug ("at open $childname for all access\n");
588 return 1 unless defined($child);
589 foreach my $v (keys %$child) {
590 if ($v =~ '^/') { # value
591 delete $child->{$v};
592 reg_debug ("at delete $childname/$v\n");
593 $child->Flush();
594 reg_debug ("at delete $childname/$v\n");
595 Time::HiRes::usleep(20000);
596 } else { # subkey
597 return 0 unless reg_delete_recurse ($child, $v);
598 }
599 }
600 #delete $child->{'/'};
601 }
602 delete $parent->{$childname};
603 reg_debug ("at delete $parentpath$childname\n");
604 $parent->Flush();
605 reg_debug ("at delete $parentpath$childname\n");
606 Time::HiRes::usleep(20000);
607 return 1;
608 }
609
610 sub cu_root {
611 my $k = $Registry -> Open("CUser", {
612 Access => KEY_FULL_ACCESS(), Delimiter => '/'
613 });
614 reg_debug ("at open HKCU for all access\n");
615 die "Cannot open HKCU for writing" unless $k;
616 return $k;
617 }
618
619 sub lm_root {
620 my $k = $Registry -> Open("LMachine", {
621 Access => ($is_admin ? KEY_FULL_ACCESS() : KEY_READ()),
622 Delimiter => '/'
623 });
624 reg_debug ("at open HKLM\n");
625 die "Cannot open HKLM for ".($is_admin ? "writing" : "reading")
626 unless $k;
627 return $k;
628 }
629
630 sub do_write_regkey {
631 my $keypath = shift; # modulo cu/lm
632 my $keyhash = shift; # ref to a possibly nested hash; empty hash allowed
633 my $remove_cu = shift;
634 die "No regkey specified" unless $keypath && defined($keyhash);
635 # for error reporting:
636 my $hivename = $is_admin ? 'HKLM' : 'HKCU';
637
638 # split into parent and final subkey
639 # remove initial slash from parent
640 # ensure subkey ends with slash
641 my ($parentpath, $keyname);
642 if ($keypath =~ /^\/?(.+\/)([^\/]+)\/?$/) {
643 ($parentpath, $keyname) = ($1, $2);
644 $keyname .= '/';
645 debug ("key - $hivename - $parentpath - $keyname\n");
646 } else {
647 die "Cannot determine final component of $keypath";
648 }
649
650 my $cu_key = cu_root();
651 my $lm_key = lm_root();
652 # cu_root() and lm_root() already die upon failure
653 my $parentkey;
654
655 # make sure parent exists
656 if ($is_admin) {
657 $parentkey = $lm_key->Open($parentpath);
658 reg_debug ("at open $parentpath; creating...\n");
659 if (!$parentkey) {
660 # in most cases, this probably shouldn't happen for lm
661 $parentkey = $lm_key->CreateKey($parentpath);
662 reg_debug ("at creating $parentpath\n");
663 }
664 } else {
665 $parentkey = $cu_key->Open($parentpath);
666 reg_debug ("at open $parentpath; creating...\n");
667 if (!$parentkey) {
668 $parentkey = $cu_key->CreateKey($parentpath);
669 reg_debug ("at creating $parentpath\n");
670 }
671 }
672 if (!$parentkey) {
673 tlwarn "Cannot create parent of $hivename/$keypath\n";
674 return 0;
675 }
676
677 # create or merge key
678 if ($parentkey->{$keyname}) {
679 hash_merge($parentkey->{$keyname}, $keyhash);
680 } else {
681 $parentkey->{$keyname} = $keyhash;
682 reg_debug ("at creating $keyname\n");
683 }
684 if (!$parentkey->{$keyname}) {
685 tlwarn "Failure to create $hivename/$keypath\n";
686 return 0;
687 }
688 if ($is_admin and $cu_key->{$keypath} and $remove_cu) {
689 # delete possibly conflicting cu key
690 tlwarn "Failure to delete $hivename/$keypath key\n" unless
691 reg_delete_recurse ($cu_key->{$parentpath}, $keyname);
692 }
693 return 1;
694 }
695
696 # remove a registry key under HKCU or HKLM, depending on privilege level
697
698 sub do_remove_regkey {
699 my $keypath = shift; # key or value
700 my $remove_cu = shift;
701 my $hivename = $is_admin ? 'HKLM' : 'HKCU';
702
703 my $parentpath = "";
704 my $keyname = "";
705 my $valname = "";
706 # two successive delimiters: value.
707 # *? = non-greedy match: want FIRST double delimiter
708 if ($keypath =~ /^(.*?\/)(\/.*)$/) {
709 ($parentpath, $valname) = ($1, $2);
710 $parentpath =~ s!^/!!; # remove leading delimiter
711 } elsif ($keypath =~ /^\/?(.+\/)([^\/]+)\/?$/) {
712 ($parentpath, $keyname) = ($1, $2);
713 $keyname .= '/';
714 } else {
715 die "Cannot determine final component of $keypath";
716 }
717
718 my $cu_key = cu_root();
719 my $lm_key = lm_root();
720 my ($parentkey, $k, $skv, $d);
721 if ($is_admin) {
722 $parentkey = $lm_key->Open($parentpath);
723 } else {
724 $parentkey = $cu_key->Open($parentpath);
725 }
726 reg_debug ("at opening $parentpath\n");
727 if (!$parentkey) {
728 debug ("$hivename/$parentpath not present or not writable".
729 " so $keypath not removed\n");
730 return 1;
731 }
732 if ($keyname) {
733 #getans("Deleting $parentpath$keyname regkey? ");
734 reg_delete_recurse($parentkey, $keyname);
735 if ($parentkey->{$keyname}) {
736 tlwarn "Failure to delete $hivename/$keypath\n";
737 return 0;
738 }
739 if ($is_admin and $cu_key->{$parentpath}) {
740 reg_delete_recurse($cu_key->{$parentpath}, $keyname);
741 if ($cu_key->{$parentpath}->{$keyname}) {
742 tlwarn "Failure to delete HKCU/$keypath\n";
743 return 0;
744 }
745 }
746 } else {
747 delete $parentkey->{$valname};
748 reg_debug ("at deleting $valname\n");
749 if ($parentkey->{$valname}) {
750 tlwarn "Failure to delete $hivename/$keypath\n";
751 return 0;
752 }
753 if ($is_admin and $cu_key->{$parentpath}) {
754 delete $cu_key->{$parentpath}->{$valname};
755 reg_debug ("at deleting $valname\n");
756 if ($cu_key->{$parentpath}->{$valname}) {
757 tlwarn "Failure to delete HKCU/$keypath\n";
758 return 0;
759 }
760 }
761 }
762 return 1;
763 }
764
765 #############################
766 # not overwriting an existing file association
767
768 # read error is sometimes access_denied,
769 # therefore we ONLY decide that a value does not exist if
770 # an attempt to read it errors out with file_not_found.
771
772 # windows error codes
773 my $file_not_found = 2; # ERROR_FILE_NOT_FOUND
774 my $reg_ok = 0; # ERROR_SUCCESS
775
776 # inaccessible value (note. actual filetypes shound not have spaces)
777 my $reg_unknown = 'not accessible';
778
779 # Effective default value of any key under Classes.
780 # admin: HKLM; user: HKCU or otherwise HKLM
781 sub current_filetype {
782 my $extension = shift;
783 my $filetype;
784 my $regerror;
785
786 if ($is_admin) {
787 $regerror = $reg_ok;
788 $filetype = lm_root()->{"Software/Classes/$extension//"} # REG_SZ
789 or $regerror = Win32API::Registry::regLastError();
790 if ($regerror != $reg_ok and $regerror != $file_not_found) {
791 return $reg_unknown;
792 }
793 } else {
794 # Mysterious failures on w7_64 => merge HKLM/HKCU info explicitly
795 # rather than checking HKCR
796 $regerror = $reg_ok;
797 $filetype = cu_root()->{"Software/Classes/$extension//"} or
798 $regerror = Win32API::Registry::regLastError();
799 if ($regerror != $reg_ok and $regerror != $file_not_found) {
800 return $reg_unknown;
801 }
802 if (!defined($filetype) or ($filetype eq "")) {
803 $regerror = $reg_ok;
804 $filetype = lm_root()->{"Software/Classes/$extension//"} or
805 $regerror = Win32API::Registry::regLastError();
806 if ($regerror != $reg_ok and $regerror != $file_not_found) {
807 return $reg_unknown;
808 }
809 };
810 }
811 $filetype = "" unless defined($filetype);
812 return $filetype;
813 }
814
815 ### now the exported file type functions ###
816
817 =pod
818
819 =item C<add_to_progids($ext, $filetype)>
820
821 Add $filetype to the list of alternate progids/filetypes of extension $ext.
822 The associated program shows up in the `open with' right-click menu.
823
824 =cut
825
826 sub add_to_progids {
827 my $ext = shift;
828 my $filetype = shift;
829 #$Registry->ArrayValues(1);
830 #do_write_regkey("Software/Classes/$ext/OpenWithProgIds/",
831 # {"/$filetype" => [0, REG_NONE()]});
832 #$Registry->ArrayValues(0);
833 do_write_regkey("Software/Classes/$ext/OpenWithProgIds/",
834 {"/$filetype" => ""});
835 }
836
837 =pod
838
839 =item C<remove_from_progids($ext, $filetype)>
840
841 Remove $filetype from the list of alternate filetypes for $ext
842
843 =cut
844
845 sub remove_from_progids {
846 my $ext = shift;
847 my $filetype = shift;
848 do_remove_regkey("Software/Classes/$ext/OpenWithProgIds//$filetype");
849 }
850
851 =pod
852
853 =item C<register_extension($mode, $extension, $file_type)>
854
855 Add registry entry to associate $extension with $file_type. Slashes
856 are flipped where necessary.
857
858 If $mode is 0, nothing is actually done.
859
860 For $mode 1, the filetype for the extension is preserved, but only
861 if there is a registry key under Classes for it. For $mode>0,
862 the new filetype is always added to the openwithprogids list.
863
864 For $mode 2, the filetype is always overwritten. The old filetype
865 moves to the openwithprogids list if necessary.
866
867 =cut
868
869 sub register_extension {
870 my $mode = shift;
871 return 1 if $mode == 0;
872 my $extension = shift;
873 # ensure leading dot
874 $extension = '.'.$extension unless $extension =~ /^\./;
875 $extension = lc($extension);
876 my $file_type = shift;
877 my $regkey;
878
879 my $old_file_type = current_filetype($extension);
880 if ($old_file_type and $old_file_type ne $reg_unknown) {
881 if ($is_admin) {
882 if (not lm_root()->{"Software/Classes/$old_file_type/"}) {
883 $old_file_type = "";
884 }
885 } else {
886 if ((not cu_root()->{"Software/Classes/$old_file_type/"}) and
887 (not lm_root()->{"Software/Classes/$old_file_type/"})) {
888 $old_file_type = "";
889 }
890 }
891 }
892 # admin: whether to remove HKCU entry. admin never _writes_ to HKCU
893 my $remove_cu = ($mode == 2) && admin();
894
895 # can do the following safely:
896 debug ("Adding $file_type to OpenWithProgIds of $extension\n");
897 add_to_progids ($extension, $file_type);
898
899 if ($old_file_type and $old_file_type ne $file_type) {
900 if ($mode == 1) {
901 debug ("Not overwriting $old_file_type with $file_type for $extension\n");
902 } else { # $mode ==2, overwrite
903 debug("Linking $extension to $file_type\n");
904 if ($old_file_type ne $reg_unknown) {
905 debug ("Moving $old_file_type to OpenWithProgIds\n");
906 add_to_progids ($extension, $old_file_type);
907 }
908 $regkey = {'/' => $file_type};
909 do_write_regkey("Software/Classes/$extension/", $regkey, $remove_cu);
910 }
911 } else {
912 $regkey = {'/' => $file_type};
913 do_write_regkey("Software/Classes/$extension/", $regkey, $remove_cu);
914 }
915 }
916
917 =pod
918
919 =item C<unregister_extension($mode, $extension, $file_type)>
920
921 Reversal of register_extension.
922
923 =cut
924
925 sub unregister_extension {
926 # we don't error check; we just do the best we can.
927 my $mode = shift;
928 return 1 if $mode == 0;
929 # mode 1 and 2 treated identically:
930 # only unregister if the current value is as expected
931 my $extension = shift;
932 my $file_type = shift;
933 $extension = '.'.$extension unless $extension =~ /^\./;
934 remove_from_progids($extension, $file_type);
935 my $old_file_type = current_filetype("$extension");
936 if ($old_file_type ne $file_type) {
937 debug("Filetype $extension now $old_file_type; not ours, so not removed\n");
938 return 1;
939 } else {
940 debug("unregistering extension $extension\n");
941 do_remove_regkey("Software/Classes/$extension//");
942 }
943 }
944
945 =pod
946
947 =item C<register_file_type($file_type, $command)>
948
949 Add registry entries to associate $file_type with $command. Slashes
950 are flipped where necessary. Double quotes should be added by the
951 caller if necessary.
952
953 =cut
954
955 sub register_file_type {
956 my $file_type = shift;
957 my $command = shift;
958 tlwarn "register_file_type called with empty command\n" unless $command;
959 $command =~s!/!\\!g;
960 debug ("Linking $file_type to $command\n");
961 my $keyhash = {
962 "shell/" => {
963 "open/" => {
964 "command/" => {
965 "/" => $command
966 }
967 }
968 }
969 };
970 do_write_regkey("Software/Classes/$file_type", $keyhash);
971 }
972
973 =pod
974
975 =item C<unregister_file_type($file_type)>
976
977 Reversal of register_file_type.
978
979 =cut
980
981 sub unregister_file_type {
982 # we don't error check; we just do the best we can.
983 # All our filetypes start with 'TL.' so we consider them
984 # our own even if they have been tampered with.
985 my $file_type = shift;
986 debug ("unregistering $file_type\n");
987 do_remove_regkey("Software/Classes/$file_type/");
988 }
989
990 =pod
991
992 =back
993
994 =head2 ACTIVATING CHANGES IMMEDIATELY
995
996 =over 4
997
998 =item C<broadcast_env>
999
1000 Broadcasts system message that enviroment has changed. This only has
1001 an effect on newly-started programs, not on running programs or the
1002 processes they spawn.
1003
1004 =cut
1005
1006 sub broadcast_env() {
1007 if ($SendMessage) {
1008 use constant HWND_BROADCAST => 0xffff;
1009 use constant WM_SETTINGCHANGE => 0x001A;
1010 my $result = "";
1011 my $ans = "12345678"; # room for dword
1012 $result = $SendMessage->Call(HWND_BROADCAST, WM_SETTINGCHANGE,
1013 0, 'Environment', 0, 2000, $ans) if $SendMessage;
1014 debug("Broadcast complete; result: $result.\n");
1015 } else {
1016 debug("No SendMessage available\n");
1017 }
1018 }
1019
1020 =pod
1021
1022 =item C<update_assocs>
1023
1024 Notifies the system that filetypes have changed.
1025
1026 =cut
1027
1028 sub update_assocs() {
1029 use constant SHCNE_ASSOCCHANGED => 0x8000000;
1030 use constant SHCNF_IDLIST => 0;
1031 if ($update_fu) {
1032 debug("Notifying changes in filetypes...\n");
1033 my $result = $update_fu->Call(SHCNE_ASSOCCHANGED, SHCNF_IDLIST, 0, 0);
1034 if ($result) {
1035 debug("Done notifying filetype changes\n");
1036 } else{
1037 debug("Failure notifying filetype changes\n");
1038 }
1039 } else {
1040 debug("No update_fu\n");
1041 }
1042 }
1043
1044 =pod
1045
1046 =back
1047
1048 =head2 SHORTCUTS
1049
1050 =over 4
1051
1052 =item C<add_shortcut($dir, $name, $icon, $prog, $args, $batgui)>
1053
1054 Add a shortcut, with name $name and icon $icon, pointing to
1055 program $prog with parameters $args (a string). Use a non-null
1056 batgui parameter if the shortcut starts a gui program via a
1057 batchfile. Then the inevitable command prompt will be hidden
1058 rightaway, leaving only the gui program visible.
1059
1060 =item C<add_desktop_shortcut($name, $icon, $prog, $args, $batgui)>
1061
1062 Add a shortcut on the desktop.
1063
1064 =item C<add_menu_shortcut($place, $name, $icon,
1065 $prog, $args, $batgui)>
1066
1067 Add a menu shortcut at place $place, relative to Start/Programs.
1068
1069 =cut
1070
1071 sub add_shortcut {
1072 my ($dir, $name, $icon, $prog, $args, $batgui) = @_;
1073
1074 # make sure $dir exists
1075 if ((not -e $dir) and (not -d $dir)) {
1076 mkdirhier($dir);
1077 }
1078 if (not -d $dir) {
1079 tlwarn ("Failed to create directory $dir for shortcut\n");
1080 return;
1081 }
1082 # create shortcut
1083 debug "Creating shortcut $name for $prog in $dir\n";
1084 my ($shc, $shpath, $shfile);
1085 $shc = new Win32::Shortcut();
1086 $shc->{'IconLocation'} = $icon if -f $icon;
1087 $shc->{'Path'} = $prog;
1088 $shc->{'Arguments'} = $args;
1089 $shc->{'ShowCmd'} = $batgui ? SW_SHOWMINNOACTIVE : SW_SHOWNORMAL;
1090 $shc->{'WorkingDirectory'} = '%USERPROFILE%';
1091 $shfile = $dir;
1092 $shfile =~ s!\\!/!g;
1093 $shfile .= ($shfile =~ m!/$! ? '' : '/') . $name . '.lnk';
1094 $shc->Save($shfile);
1095 }
1096
1097 sub desktop_path() {
1098 return Win32::GetFolderPath(
1099 (admin() ? Win32::CSIDL_COMMON_DESKTOPDIRECTORY :
1100 Win32::CSIDL_DESKTOPDIRECTORY), CREATE);
1101 }
1102
1103 sub menu_path() {
1104 return Win32::GetFolderPath(
1105 (admin() ? Win32::CSIDL_COMMON_PROGRAMS : Win32::CSIDL_PROGRAMS), CREATE);
1106 }
1107
1108 sub add_desktop_shortcut {
1109 my ($name, $icon, $prog, $args, $batgui) = @_;
1110 add_shortcut (desktop_path(), $name, $icon, $prog, $args, $batgui);
1111 }
1112
1113 sub add_menu_shortcut {
1114 my ($place, $name, $icon, $prog, $args, $batgui) = @_;
1115 $place =~ s!\\!/!g;
1116 my $shdir = menu_path() . ($place =~ m!^/!=~ '/' ? '' : '/') . $place;
1117 add_shortcut ($shdir, $name, $icon, $prog, $args, $batgui);
1118 }
1119
1120
1121 =pod
1122
1123 =item C<remove_desktop_shortcut($name)>
1124
1125 For uninstallation of an individual package.
1126
1127 =item C<remove_menu_shortcut($place, $name)>
1128
1129 For uninstallation of an individual package.
1130
1131 =cut
1132
1133 sub remove_desktop_shortcut {
1134 my $name = shift;
1135 unlink desktop_path().'/'.$name.'.lnk';
1136 }
1137
1138 sub remove_menu_shortcut {
1139 my $place = shift;
1140 my $name = shift;
1141 $place =~ s!\\!/!g;
1142 $place = '/'.$place unless $place =~ m!^/!;
1143 unlink menu_path().$place.'/'.$name.'.lnk';
1144 }
1145
1146 =pod
1147
1148 =back
1149
1150 =head2 UNINSTALLER
1151
1152 =over 4
1153
1154 =item C<create_uninstaller>
1155
1156 Writes registry entries for add/remove programs which reference
1157 the uninstaller script and creates uninstaller batchfiles to finish
1158 the job.
1159
1160 =cut
1161
1162 sub create_uninstaller {
1163 # TEXDIR
1164 &log("Creating uninstaller\n");
1165 my $td_fw = shift;
1166 $td_fw =~ s!\\!/!;
1167 my $td = $td_fw;
1168 $td =~ s!/!\\!g;
1169
1170 my $tdmain = `"$td\\bin\\windows\\kpsewhich" -var-value=TEXMFMAIN`;
1171 $tdmain =~ s!/!\\!g;
1172 chomp $tdmain;
1173
1174 my $uninst_fw = "$td_fw/tlpkg/installer";
1175 my $uninst_dir = $uninst_fw;
1176 $uninst_dir =~ s!/!\\!g;
1177 mkdirhier("$uninst_fw"); # wasn't this done yet?
1178 if (! (open UNINST, ">", "$uninst_fw/uninst.bat")) {
1179 tlwarn("Failed to create uninstaller\n");
1180 return 0;
1181 }
1182 print UNINST <<UNEND;
1183 rem \@echo off
1184 setlocal
1185 path $td\\tlpkg\\tlperl\\bin;$td\\bin\\windows;%path%
1186 set PERL5LIB=$td\\tlpkg\\tlperl\\lib
1187 rem Clean environment from other Perl variables
1188 set PERL5OPT=
1189 set PERLIO=
1190 set PERLIO_DEBUG=
1191 set PERLLIB=
1192 set PERL5DB=
1193 set PERL5DB_THREADED=
1194 set PERL5SHELL=
1195 set PERL_ALLOW_NON_IFS_LSP=
1196 set PERL_DEBUG_MSTATS=
1197 set PERL_DESTRUCT_LEVEL=
1198 set PERL_DL_NONLAZY=
1199 set PERL_ENCODING=
1200 set PERL_HASH_SEED=
1201 set PERL_HASH_SEED_DEBUG=
1202 set PERL_ROOT=
1203 set PERL_SIGNALS=
1204 set PERL_UNICODE=
1205
1206 perl.exe \"$tdmain\\scripts\\texlive\\uninstall-windows.pl\" \%1
1207
1208 if errorlevel 1 goto :eof
1209 rem test for taskkill and try to stop exit tray menu
1210 taskkill /? >nul 2>&1
1211 if not errorlevel 1 1>nul 2>&1 taskkill /IM tl-tray-menu.exe /f
1212 copy \"$uninst_dir\\uninst2.bat\" \"\%TEMP\%\"
1213 rem pause
1214 \"\%TEMP\%\\uninst2.bat\"
1215 UNEND
1216 ;
1217 close UNINST;
1218
1219 # We could simply delete everything under the root at one go,
1220 # but this might be catastrophic if TL doesn't have its own root.
1221 if (! (open UNINST2, ">$uninst_fw/uninst2.bat")) {
1222 tlwarn("Failed to complete creating uninstaller\n");
1223 return 0;
1224 }
1225 print UNINST2 <<UNEND2;
1226 rmdir /s /q \"$td\\bin\"
1227 rmdir /s /q \"$td\\readme-html.dir\"
1228 rmdir /s /q \"$td\\readme-txt.dir\"
1229 if exist \"$td\\temp\" rmdir /s /q \"$td\\temp\"
1230 rmdir /s /q \"$td\\texmf-dist\"
1231 rmdir /s /q \"$td\\tlpkg\"
1232 del /q \"$td\\README.*\"
1233 del /q \"$td\\LICENSE.*\"
1234 if exist \"$td\\doc.html\" del /q \"$td\\doc.html\"
1235 del /q \"$td\\index.html\"
1236 del /q \"$td\\texmf.cnf\"
1237 del /q \"$td\\texmfcnf.lua\"
1238 del /q \"$td\\install-tl*.*\"
1239 del /q \"$td\\tl-tray-menu.exe\"
1240 rem del /q \"$td\\texlive.profile\"
1241 del /q \"$td\\release-texlive.txt\"
1242 UNEND2
1243 ;
1244 for my $d ('TEXMFSYSVAR', 'TEXMFSYSCONFIG') {
1245 my $kd = `"$td\\bin\\windows\\kpsewhich" -var-value=$d`;
1246 chomp $kd;
1247 print UNINST2 "rmdir /s /q \"", $kd, "\"\r\n";
1248 }
1249 if ($td !~ /^.:$/) { # not root of drive; remove directory if empty
1250 print UNINST2 <<UNEND3;
1251 for \%\%f in (\"$td\\*\") do goto :done
1252 for /d \%\%f in (\"$td\\*\") do goto :done
1253 rd \"$td\"
1254 :done
1255 \@echo Done uninstalling TeXLive.
1256 \@pause
1257 del \"%0\"
1258 UNEND3
1259 ;
1260 }
1261 close UNINST2;
1262 # user install: create uninstaller shortcut
1263 # admin install: no shortcut because it would be visible to
1264 # users who are not authorized to run it
1265 if (!admin()) {
1266 &log("Creating shortcut for uninstaller\n");
1267 TeXLive::TLWinGoo::add_menu_shortcut(
1268 $TeXLive::TLConfig::WindowsMainMenuName, "Uninstall TeX Live", "",
1269 "$uninst_dir\\uninst.bat", "", 0);
1270 }
1271 # register uninstaller
1272 # but not for a user install under win10 because then
1273 # it shows up in Settings / Apps / Apps & features,
1274 # where it will trigger an inappropriate UAC prompt
1275 if (admin() || !is_ten()) {
1276 &log("Registering uninstaller\n");
1277 my $k;
1278 my $uninst_key = $Registry -> Open((admin() ? "LMachine" : "CUser") .
1279 "/software/microsoft/windows/currentversion/",
1280 {Access => KEY_FULL_ACCESS()});
1281 if ($uninst_key) {
1282 $k = $uninst_key->CreateKey(
1283 "uninstall/TeXLive$::TeXLive::TLConfig::ReleaseYear/");
1284 if ($k) {
1285 $k->{"/DisplayName"} = "TeX Live $::TeXLive::TLConfig::ReleaseYear";
1286 $k->{"/UninstallString"} = "\"$td\\tlpkg\\installer\\uninst.bat\"";
1287 $k->{'/DisplayVersion'} = $::TeXLive::TLConfig::ReleaseYear;
1288 $k->{'/Publisher'} = 'TeX Live';
1289 $k->{'/URLInfoAbout'} = "http://www.tug.org/texlive";
1290 }
1291 }
1292 if (!$k and admin()) {
1293 tlwarn("Failed to register uninstaller\n".
1294 "You can still run $td\\tlpkg\\installer\\uninst.bat manually.\n");
1295 return 0;
1296 }
1297 }
1298 }
1299
1300 =pod
1301
1302 =item C<unregister_uninstaller>
1303
1304 Removes TeXLive from Add/Remove Programs.
1305
1306 =cut
1307
1308 sub unregister_uninstaller {
1309 my ($w32_multi_user) = @_;
1310 my $regkey_uninst_path = ($w32_multi_user ? "LMachine" : "CUser") .
1311 "/software/microsoft/windows/currentversion/uninstall/";
1312 my $regkey_uninst = $Registry->Open($regkey_uninst_path,
1313 {Access => KEY_FULL_ACCESS()});
1314 reg_delete_recurse(
1315 $regkey_uninst, "TeXLive$::TeXLive::TLConfig::ReleaseYear/")
1316 if $regkey_uninst;
1317 tlwarn "Failure to unregister uninstaller\n" if
1318 $regkey_uninst->{"TeXLive$::TeXLive::TLConfig::ReleaseYear/"};
1319 }
1320
1321 =pod
1322
1323 =back
1324
1325 =head2 ADMIN
1326
1327 =over 4
1328
1329 =item C<TeXLive::TLWinGoo::maybe_make_ro($dir)>
1330
1331 Write-protects a directory $dir recursively, using ACLs, but only if
1332 we are a multi-user install, and only if $dir is on an
1333 NTFS-formatted local fixed disk, and only on Windows Vista and
1334 later. It writes a log message what it does and why.
1335
1336 =back
1337
1338 =cut
1339
1340 sub maybe_make_ro {
1341 my $dir = shift;
1342 debug ("Calling maybe_make_ro on $dir\n");
1343 tldie "$dir not a directory\n" unless -d $dir;
1344 if (!admin()) {
1345 log "Not an admin install; not making read-only\n";
1346 return 1;
1347 }
1348
1349 $dir = Cwd::abs_path($dir);
1350
1351 # GetDriveType: check that $dir is on local fixed disk
1352 # need to feed GetDriveType the drive root
1353 my ($volume,$dirs,$file) = File::Spec->splitpath($dir);
1354 debug "Split path: | $volume | $dirs | $file\n";
1355 # GetDriveType won't handle UNC paths so handle this case separately
1356 if ($volume =~ m!^[\\/][\\/]!) {
1357 log "$dir on UNC network path; not making read-only\n";
1358 return 1;
1359 }
1360 my $dt = Win32API::File::GetDriveType($volume);
1361 debug "Drive type $dt\n";
1362 if ($dt ne Win32API::File::DRIVE_FIXED) {
1363 log "Not a local fixed drive; not making read-only\n";
1364 return 1;
1365 }
1366
1367 # FsType: test for NTFS, or, better, check whether ACLs are supported
1368 # FsType needs to be called for the current directory
1369 my $curdir = Cwd::getcwd();
1370 debug "Current directory $curdir\n";
1371 chdir $dir;
1372 my $newdir = Cwd::getcwd();
1373 debug "New current directory $newdir\n";
1374 tldie "Cannot cd to $dir, current dir is $newdir\n" unless
1375 lc($newdir) eq lc($dir);
1376 my ($fstype, $flags, $maxl) = Win32::FsType(); # of current drive
1377 if (!($flags & 0x00000008)) {
1378 log "$dir does not supports ACLs; not making read-only\n";
1379 # go back to original directory
1380 chdir $curdir;
1381 return 1;
1382 }
1383
1384 # ran out of excuses: do it
1385 # we use cmd /c
1386 # $dir now being the current directory, we can save ourselves
1387 # some quoting troubles by using . for $dir.
1388
1389 # some 'well-known sids':
1390 # S-1-5-11 Authenticated users
1391 # S-1-5-32-545 Users
1392 # S-1-5-32-544 administrators
1393 # S-1-3-0 creator owner (does not work right)
1394 # S-1-3-1 creator group
1395
1396 # /reset is necessary for removing non-standard existing permissions
1397 my $cmd = 'cmd /c "icacls . /reset && icacls . /inheritance:r'.
1398 ' /grant:r *S-1-5-32-544:(OI)(CI)F'.
1399 ' /grant:r *S-1-5-11:(OI)(CI)RX /grant:r *S-1-5-32-545:(OI)(CI)RX"';
1400 log "Making read-only\n".Encode::decode(console_out,`$cmd`)."\n";
1401
1402 # go back to original directory
1403 chdir $curdir;
1404 return 1;
1405 }
1406
1407 # needs a terminal 1 for require to succeed!
1408 1;
1409
1410 ### Local Variables:
1411 ### perl-indent-level: 2
1412 ### tab-width: 2
1413 ### indent-tabs-mode: nil
1414 ### End:
1415 # vim:set tabstop=2 expandtab: #