NetNews Usenet Archive 1992 #20/NN_1992_20.iso/spool/comp/lang/perl/5787

Internet Message Format | 1992-09-08 | 5.3 KB

Xref: sparky comp.lang.perl:5787 alt.sources:2025
Newsgroups: comp.lang.perl,alt.sources
Path: sparky!uunet!mcsun!sun4nl!mhres!pronto!jv
From: [e-mail] (Johan Vromans)
Subject: SOURCE: Relink symbolic links (enhanced version)
Message-ID: <[e-mail]>
X-Md4-Signature: 05bc6d0845ef480fb37e64a2880ac57a
Sender: [e-mail] (Johan Vromans)
Organization: Multihouse Automation, the Netherlands
Date: Wed, 9 Sep 1992 08:02:44 GMT
Lines: 185

Archive-name: relink
Submitted-by: [e-mail] (Johan Vromans)
Version: 1.2

This little goodie is a slightly enhanced version of the 'relink'
program as included in the perl 'eg' library and Camel book. It has
better error checking and a few interesting options. And it doesn't
push the input from STDIN on ARGV.

One of our system administration scripts maintains a list of all
symlinks on the system in the format 'filename -> where_it_links_to',
a format that is also understood by this version of relink. So it is
usually faster to execute

  % grep 'epoch-4.0p2' /usr/tmp/symlinks | relink -verbose 's/4.0p2/4.2/'

than to use a 'find'.

Happy hacking!

---- Cut Here and feed the following to sh ----
#!/bin/sh
# This is a shell archive (produced by shar 3.49)
# To extract the files from this archive, save it to a file, remove
# everything above the "!/bin/sh" line above, and type "sh file_name".
#
# made 09/09/1992 07:53 UTC by jv@largo
# Source directory /nfs/pronto/mozart/users/jv/src
#
# existing files will NOT be overwritten unless -c is specified
#
# This shar contains:
# length  mode       name
# ------ ---------- ------------------------------------------
#   2883 -r--r--r-- relink.pl
#
# ============= relink.pl ==============
if test -f 'relink.pl' -a X"$1" != X"-c"; then
    echo 'x - skipping relink.pl (File already exists)'
else
echo 'x - extracting relink.pl (Text)'
sed 's/^X//' << 'SHAR_EOF' > 'relink.pl' &&
X#!/usr/local/bin/perl
X# relink.pl -- change symlinks
X# SCCS Status     : @(#)@ relink.pl    1.2
X# Author          : Johan Vromans
X# Created On      : Sun Sep  6 14:19:41 1992
X# Last Modified By: Johan Vromans
X# Last Modified On: Sun Sep  6 15:55:31 1992
X# Update Count    : 31
X# Status          : Unknown, Use with caution!
X
X# This program is almost identical to 'relink' from the perl examples.
X# However, it has more extensive error detection.
X# Also, it allows input lines to contain 'filename -> link-value'.
X# In this case, the filename is checked to point to link-value.
X
X&stdio;
X&usage if @ARGV < 1;
X&options if $ARGV[0] =~ /^-/;
X$opt_verbose = defined $opt_verbose;
X$opt_noaction = defined $opt_noaction;
X
X# Get the perl expression from the command line.
X$expr = shift (@ARGV);
X
X# Go for it!
Xif ( @ARGV ) {
X    # Take filenames from command line.
X    foreach ( @ARGV ) {
X    &relink($_);
X    }
X}
Xelse {
X    # Take filenames from standard input.
X    while ( <STDIN> ) {
X    chop;
X    if ( /\s+->\s+/ ) {
X        # The link value is specified, check it.
X        &relink($`, $');
X    }
X    else {
X        # Normal procedure.
X        &relink($_);
X    }
X    }
X}
X
Xexit(0);
X
X################ Subroutines ################
X
Xsub relink {
X    local ($name, $old) = @_;
X    local ($new);
X    local (@st) = lstat($name);
X
X    # Did the lstat succeed?
X    unless ( defined $st[0] ) {
X    print STDERR ("Warning: $!: $name (lstat)\n");
X    return;
X    }
X
X    # Is it a symlink?
X    unless ( -l _ ) {
X    print STDERR ("Warning: Not a symlink: $name\n");
X    return;
X    }
X
X    # Get the link value, and verify it if possible.
X    $_ = readlink($name);
X    if ( defined $old && $old ne $_ ) {
X    print STDERR ("Error: Mismatch: $name ($old <-> $_)\n");
X    return;
X    }
X
X    # Transform.
X    $old = $_;
X    eval($expr);
X    die ("Fatal: $@") if $@;
X    $new = $_;
X
X    # Is it changed?
X    if ( $old eq $new ) {
X    print STDERR ("Warning: No change: $name\n");
X    return;
X    }
X
X    # Relink it.
X    if ( $opt_noaction || unlink($name) == 1 ) {
X    symlink($new, $name) unless $opt_noaction;
X    print STDERR ($opt_noaction ? 'Info: ' : '',
X              "$name: $old => $new\n") if $opt_verbose;
X    }
X    else {
X    # Could not unlink.
X    print STDERR ("Error: $!: $name (unlink)\n");
X    return;
X    }
X}
X
Xsub usage {
X    print STDERR <<EOD;
XUsage: relink.pl perl-expr [options] [ filename ... ]
X
XOptions:
X    -noaction    do not relink
X    -verbose    supply verbose info
X    -help    this info
XFilenames will be read from STDIN if not supplied on the command line.
XEOD
X    exit(1);
X}
X
Xsub options {
X    local ($opt_help) = 0;
X    local ($opt_ident) = 0;
X    require "newgetopt.pl";
X    if (!&NGetOpt("noaction",
X          "verbose", "ident", "help") || $opt_help) {
X    &usage;
X    }
X    print STDERR ("This is relink.pl version 1.2\n") if $opt_ident;
X}
X
Xsub stdio {
X    if ( -t STDOUT && -t STDERR ) {
X    close (STDERR);
X    open (STDERR, '>-');
X    select (STDERR); $| = 1;
X    }
X}
SHAR_EOF
chmod 0444 relink.pl ||
echo 'restore of relink.pl failed'
Wc_c="`wc -c < 'relink.pl'`"
test 2883 -eq "$Wc_c" ||
    echo 'relink.pl: original size 2883, current size' "$Wc_c"
fi
exit 0
--
Johan Vromans                       [e-mail] via internet backbones
Multihouse Automatisering bv               uucp:..!{uunet,sun4nl}!mh.nl!jv
Doesburgweg 7, 2803 PL Gouda, The Netherlands  phone/fax: [phone]/62500
------------------------ "Arms are made for hugging" -------------------------