readlink is not recursive in cygwin (no -f option)

[Marcos Lorenzo]

I made some kind of patch to use ActivePerl within a cygwin console. The
problem was that ActivePerl doesn't dupport posix paths so I made the
following:

1) A readlink recursive that returns the real file:

#!/bin/perl

# script that does recursive readlink

# exit with error status if no arg or arg doesn't exist or is not a symlink
if($ARGV[0] eq "" or ! -e $ARGV[0] or ! -l $ARGV[0]){ exit 1; }

$file=$ARGV[0];

$realfile="";      # this will store each dir in $file for each iteration in do-while
$restofpath=$file; # the rest of the path that is to be checked
$nextdir=$file;    # the next dir to check


do{
   $nextdir=~s/^(\/{1}[^\/]*)\/{1}.*$/$1/;
   $realfile=$realfile.$nextdir;
   $restofpath=~s/^\/{1}[^\/]*//;
   #print "\nnextdir: $nextdir\n";
   #print "realfile: $realfile";
   if(-l $realfile){
      $realfile=readlink "$realfile"; $realfile=~s/\/{1}$//;
      #print " -> link to $realfile";
      if ($restofpath eq ""){ $restofpath=$realfile; $realfile=""; $nextdir=$realfile; }
   }
   #print "\nrestofpath: $restofpath\n";
   # update variables for next iteration
   $nextdir=$restofpath;
}until($restofpath eq "");

# return the real file
print "$realfile\n";


2) a "interpreter" to make a workaround:

#!/bin/bash

# script that tricks ActivePerl for Windows to work on Perl scripts under cygwin
# (a workaround for posix-windows paths)

# TODO: eventhough this is a workaround, perl doesn't support symlinks, so I need
#       a function that does(ie): getrealfile /usr/local/bin/xnet, returns
#       /dit/DIT/scripts/cygwin-scripts/xnet
#       `-> done: function is readlink, although it doesn't support the -f option
#                 as in linux, it's not recursive.
#                 I made a script that implements this (rreadlink)
#

# $ActivePerl is a symbolic link to wherever the real ActivePerl perl.exe resides
ActivePerl=/usr/local/bin/perl

file=`rreadlink "$1"`
shift
args="$@"

path=`expr $file ':' '\(.*\)\/\.*' '|' $file`
script=`expr $file ':' '.*\/\(.*\)' '|' $file`

cd $path
$ActivePerl $script $args
cd $OLDPWD

3) Now this can be used for executing ActivePerl scripts:

#!/usr/local/bin/activeperl_trick
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
See the interpreter here

use Win32::Service;
use Sys::Hostname;
use Win32;
use strict;
#
my %service_states =
(
	"stopped"             =>  0x00000001,
	"start pending"       =>  0x00000002,
	"stop pending"        =>  0x00000003,
	"running"             =>  0x00000004,
	"continue pending"    =>  0x00000005,
	"pause pending"       =>  0x00000006,
	"paused"              =>  0x00000007,
);
my %service_codes = reverse (%service_states);
#
my $HOSTNAME = hostname;
my $op = lc shift;
my ($server, $service);
$server = '' unless $server = shift;
$service = '' unless $service = shift;
if ($server ne '' and $server !~ /^\\/){
	$service = $server;
	$server = '';
}
if ($op eq 'status'){
	if ($server ne ''){
	   print "\t\t\t\\$server status:\n-------------------------------------------------------------------\n";
	   &status ("\\$server", $service);
	   exit;
   	}else{
	   print "\t\t\t\\\\$HOSTNAME status:\n-------------------------------------------------------------------\n";
	   &status ($server, $service) unless $server ne '';
	   exit;
	}
}
if ($op =~ /^(?:start|stop|pause|resume)$/){
	if ($service eq ''){
	   print "You must specify a service for this option.\n";
	   exit 1
	}
	&process ($op, $server, $service);
	sleep 1;
	&status ($server, $service);
	exit;
}
if ($op eq 'restart'){
	if ($service eq ''){
	   print "You must specify a service for this option.\n";
	   exit 1
	}
	#print "Restarting $service...\n";
	#&process ('stop', $server, $service);
	#sleep 1;
	#&status ($server, $service);
	&process ('restart', $server, $service);
	#sleep 1;
	#&status ($server, $service);
	exit;
}
#
print STDERR "Usage:  $0 status|start|stop|restart|pause|resume [\\\\server] [service_short_name]\n";
exit;
#
sub status{
    my ($server, $service) = @_;
	my ($err, %status, %services, %rservices);
	if ($service)	{
		$err = Win32::Service::GetStatus($server,$service,\%status);
		if (!$err) {&display_error; return};
		print "$service is $service_codes{$status{CurrentState}}\n";
	}
	else	{
		$err = Win32::Service::GetServices($server,\%services);
		if (!$err) {&display_error; return};
		%rservices = reverse %services;
		foreach $service (sort {lc $a cmp lc $b} keys %rservices){
			$err = Win32::Service::GetStatus($server,$service,\%status);
			if (!$err) {print "$service: "; &display_error; next};
			print "$service_codes{$status{CurrentState}}: $service [$rservices{$service}]\n";
		}
	}
}
#
sub process{
	my ($process,$server, $service) = @_;
	my $err;
	if ($process eq 'start') {
		print "Starting $service... ";
		{$err = Win32::Service::StartService($server,$service) and return}
	}
	if ($process eq 'stop') {
		print "Stopping $service... ";
		{$err = Win32::Service::StopService($server,$service) and return}
	}
	if ($process eq 'restart') {
		print "Restarting $service...\n\n";
		print "Stopping $service... ";
		{$err = Win32::Service::StopService($server,$service)}
		sleep 1;
        	&status ($server, $service);
		print "Starting $service... ";
		{$err = Win32::Service::StartService($server,$service)}
		sleep 1;
        	&status ($server, $service);
	}
	if ($process eq 'pause') {
		print "Pausing $service... ";
		{$err = Win32::Service::PauseService($server,$service) and return}
	}
	if ($process eq 'resume') {
		print "Resuming $service... ";
		{$err = Win32::Service::ResumeService($server,$service) and return}
	}
	if (!$err) {&display_error}
}
#
sub display_error{
	my $err = Win32::GetLastError();
	print STDERR Win32::FormatMessage($err);
}


This latest script is for checking status/starting/stoping services via
ActivePerl. The advantage is that this can check other computers services
(within our domain and if we have the required privileges).


I hope this helps anyone.

Cheers,
m4c.



-- 
##########################################################################
"And the next time you consider complaining that running Lucid Emacs
19.05 via NFS from a remote Linux machine in Paraguay doesn't seem to
get the background colors right, you'll know who to thank."
(By Matt Welsh)


                                                                  ...
  _________     Marcos Lorenzo de Santiago (Labs Technician)    /`   `\
 |~~      @|    Departament of Telematic Engineering           /       \
 |  ====   |                                                  |\~~~~~~~/|
 |  ====   |    E-mail:   marcos@it.uc3m.es                   | \=====/ |
 |_________|    Telephone: (+34)91-624-8757                   | /`...'\ |
                Homepage: http://www.it.uc3m.es/marcos        |/_______\|

##########################################################################




--
Unsubscribe info:      http://cygwin.com/ml/#unsubscribe-simple
Bug reporting:         http://cygwin.com/bugs.html
Documentation:         http://cygwin.com/docs.html
FAQ:                   http://cygwin.com/faq/