sprintf( @_ ) doesn't do what I want!

harangzsolt33 has asked for the wisdom of the Perl Monks concerning the following question:

I have two questions. First, of all I have written a sub called cprintf(COLOR, TEXT) that prints something colorful on the screen. For some reason, the Linux version of this sub works, which says printf(@_); but when I do my $S = sprintf(@_); instead of giving me the formatted string, "1" is returned. Why?? I thought printf and sprintf are basically the same, the only difference is that sprintf returns the string instead of printing it to stdout.

The second question is has anyone ever written a perl module that does what I am trying to do here? As you can see, I have created a sub called CLS(), MoveCursor, cprintf() to print in color in DOS mode and Linux, but maybe I've worked in vain. Maybe others have already done something like this before?

Edit: I've come back here to make corrections in my code (in case someone wants to use it. :P )


#!/usr/bin/perl -w

use strict;
use warnings;
use Config;

my $OS   = GetOS();
my $X64  = is64bitOS();
my @TERM = GetConsoleSize();

##################################################
# This function returns the character width and height
# of the console window as an array.
# Usage: ARRAY = GetConsoleSize()
#
# $ARRAY[0] = WIDTH
# $ARRAY[1] = HEIGHT
#
sub GetConsoleSize
{
  my $WIDTH = 80;
  my $HEIGHT = 25;
  if ($OS == 1)        # DOS: Use an assembly code
  {
    # In DOS mode, we acquire the screen width by calling BIOS INT 10.
+..
    my $OUTPUT = ExecX86('SCRWIDTH.COM', "\xB4\x0F\xCD\x10\xA3\0\1\xC6
+\6\2\1\$\xB4\t\xBA\0\1\xCD!\xC3");
    if (length($OUTPUT) == 2) { $WIDTH = vec($OUTPUT, 1, 8); }
  }
  elsif ($OS == 2)    # Windows: Use powershell
  {
    my $W = uc(`POWERSHELL -COMMAND ECHO \$HOST.UI.RAWUI`);
    my @N = SplitNumbers(TrimChar(Between($W, 'WINDOWSIZE', "\n"), ' :
+'));
    if (@N == 3) { $WIDTH = $N[0]; $HEIGHT = $N[2]; }
  }
  else            # Linux: Use tput ...
  {
    $WIDTH = `tput cols`;
    $HEIGHT = `tput lines`;
  }
  return ($WIDTH, $HEIGHT);
}
##################################################
# Prints ANSI codes to stdout that changes the color.
# This function works under LINUX/OSX ONLY!
# Usage: ChangeColor(INTEGER)
#
sub ChangeColor
{
  $OS > 2 or return;

  my $C = shift;
  my $A = ($C & 0xF00) >> 8; # Get attrib
  my $B = ($C & 0x0F0) >> 4; # Get background color
  my $T = ($C & 0x00F);      # Get text color
  my $E = '2648375vnrptosqu';
  $E = "\x1B[" . (vec($E, $T, 8) - 20) . "m\x1B[" . (vec($E, $B, 8) - 
+10) . 'm';

  if ($A & 1) { $E .= "\x1B[05m"; }  # BLINKING
  if ($A & 2) { $E .= "\x1B[04m"; }  # UNDERLINE
  if ($A & 4) { $E .= "\x1B[03m"; }  # ITALIC
  if ($A & 8) { $E .= "\x1B[01m"; }  # BOLD
  print $E;
}
##################################################
#
# Prints ANSI codes to stdout that changes the
# color back to default.
# Usage: ResetColor()
#
sub ResetColor
{
  $OS > 2 or return;
  print "\x1B[0m";
}
##################################################
# Prints some text in the center of the screen.
# If given more than one argument, each
# argument will be printed on a new line.
# Usage: CENTER(STRINGS...)
#
sub CENTER
{
  my $WIDTH = $TERM[0];
  my $PADDING;
  my $TEXT;
  print "\n";
  foreach my $L (@_)
  {
    $TEXT = substr($L, 0, $WIDTH);
    $PADDING = int(($WIDTH - length($TEXT)) / 2);
    print ' ' x $PADDING, $TEXT;
    length($TEXT) == $WIDTH or print "\n";
  }
}
##################################################
# Splits a string along numbers and returns an
# array of alternating numbers and text.
# Usage: ARRAY = SplitNumbers(STRING)
#
# Example: SplitNumbers('6500 Main St, Miami, FL 33014') --->
#
#    ('6500', ' Main St, Miami, FL ', '33014')
#
sub SplitNumbers
{
  defined $_[0] or return ();
  my ($PTR, $PREV, $LEN, $TYPE, @A) = (0, -1, length($_[0]));
  $LEN or return ();

# Possible values for $PREV: -1=Uninitialized 0=NUMBER 1=TEXT

  for (my $i = 0; $i < $LEN; $i++)
  {
    $TYPE = vec($_[0], $i, 8);
    $TYPE = $TYPE < 48 || $TYPE > 57;    # Is it a number?
    if ($PREV == !$TYPE)        # Same as before?
    {
      push(@A, substr($_[0], $PTR, $i-$PTR));
      $PTR = $i;
    }
    $PREV = $TYPE;
  }
  push(@A, substr($_[0], $PTR));    # Process last chunk
  return @A;
}
##################################################
# Extracts a section from string S that lies between
# the first occurrence of strings A and B. Returns
# an empty string if A is not found.
# Usage: STRING = Between(S, A, [B])
#
sub Between
{
  (defined $_[0] && defined $_[1]) or return '';
  (length($_[0]) && length($_[1])) or return '';
  my $p1 = index($_[0], $_[1]);
  return '' if ($p1 < 0);
  my $B = defined $_[2] ? $_[2] : '';
  length($B) or return substr($_[0], $p1);
  my $p2 = index($_[0], $B, $p1 + length($_[1]));
  return '' if ($p2 <= $p1);
  my $start = $p1 + length($_[1]);
  return substr($_[0], $start, $p2 - $start);
}
##################################################
# Just like Trim(), this function can remove spaces
# or tabs from before and after STRING but it can also
# remove any other character, whatever is found in SUBSTR.
# Usage: STRING = TrimChar(STRING, SUBSTR)
#
sub TrimChar
{
  defined $_[0] or return '';
  my $L = length($_[0]);
  $L or return '';
  defined $_[1] or return $_[0];
  length($_[1]) or return $_[0];
  my $START = 0;
  my $LAST = 0;
  while ($L--)
  {
    if (index($_[1], substr($_[0], $L, 1)) < 0)
    {
      $START = $L;
      $LAST or $LAST = $L + 1;
    }
  }
  return substr($_[0], $START, $LAST - $START);
}
##################################################
# Removes whitespace from before and after STRING.
# Whitespace is here defined as any byte whose
# ASCII value is less than 33. That includes
# tabs, esc, null, vertical tab, new lines, etc.
# Usage: STRING = Trim(STRING)
#
sub Trim
{
  defined $_[0] or return '';
  my $L = length($_[0]);
  $L or return '';
  my $P = 0;
  while ($P <= $L && vec($_[0], $P++, 8) < 33) {}
  for ($P--; $P <= $L && vec($_[0], $L--, 8) < 33;) {}
  substr($_[0], $P, $L - $P + 2)
}
#################################################
#
# This function returns the OS type as a number.
# 1=DOS 2=WINDOWS 3=LINUX 4=OSX 9=OTHER
#
sub GetOS
{
  my $OS = uc($^O);
  index($OS, 'LINUX')  >= 0 ? 3 :
  index($OS, 'MSWIN')  >= 0 ? 2 :
  index($OS, 'DOS')    >= 0 ? 1 :
  index($OS, 'DARWIN') >= 0 ? 4 : 9;
}
#################################################
# This function works like the index() function.
# N is the start position. Uses rindex() when N
# is negative. Returns -1 if nothing was found,
# OR returns the position where SUBSTR was found.
# Usage: INTEGER = IndexOf(STRING, SUBSTR, [N])
#
sub IndexOf
{
  @_ > 1 or return -1;
  my $P = defined $_[2] ? $_[2] : 0;
  $P < 0 ? rindex($_[0], $_[1], $P + length($_[0])) : index($_[0], $_[
+1], $P);
}
#################################################
# This function splits STRING into two parts along the
# first occurrence of SUBSTR. The two resulting string
# segments are stored in $a and $b. The search for
# SUBSTR starts at position N. If N is -1, then
# starts searching from the end of the string.
# Returns 0 if SUBSTR was not found, OR
# returns POSITION+1 where SUBSTR was found.
# If SUBSTR is not found, the entire input string
# will be stored in $a, while $b will be empty.
# Usage: FOUND = SplitAB(STRING, SUBSTR, [N])
#
sub SplitAB
{
  $a = $b = '';
  @_ > 1 or return 0;
  my $P = IndexOf(@_);
  if ($P < 0) { $a = $_[0]; return 0; }
  $a = substr($_[0], 0, $P);
  $b = substr($_[0], $P + length($_[1]));
  return $P + 1;
}
#################################################
#
# This function clears the terminal window.
#
sub CLS
{
     if ($OS == 3) { print "\x1Bc\x1B[0m\x1B[3J\x1B[H\x1B[2J"; }
  elsif ($OS == 1) { system('COMMAND.COM /C CLS'); }
  elsif ($OS == 2) { system('CLS'); }
  elsif ($OS == 4) { print "\x1B[3J"; }
}
#################################################
# LINUX/OSX ONLY!
# Changes the cursor's position within the
# terminal window using ANSI codes.
# Usage: MoveCursor(X, Y)
#
sub MoveCursor
{
  $OS > 2 or return;
  my $X = defined $_[0] ? $_[0] : 1;
  my $Y = defined $_[1] ? $_[1] : 1;
  $X > 0 or $X = 1;
  $Y > 0 or $Y = 1;
  print "\x1B[$Y;$X", 'H';
}
##################################################
# This function expects a full path and returns
# the file name portion of the path.
# Usage: FILE_NAME = GetFileName(FULL_PATH)
#
sub GetFileName
{
  defined $_[0] or return '';
  my $F = $_[0];
  $OS > 2 or $F =~ tr|\\|/|;
  my $P = rindex($F, '/');
  return ($P < 0) ? $F : substr($F, $P+1);
}
#################################################
# This function executes x86 binary code in DOS/Windows.
# Tested using TinyPerl 5.8 with Windows 7 Ultimate 32-bit,
# Windows XP PRO SP2 (32-bit), and DOS Perl 5.004_02.
# Returns whatever the program prints to stdout or
# returns an empty string if something went wrong.
# The PROGRAM string should contain the name of
# the file (to be created) and any arguments
# that may need to be passed.
# Usage: STRING = ExecX86(PROGRAM, BINARY)
# Example: ExecX86('MVCURSOR.COM 4 12', '...');
#
sub ExecX86
{
  @_ == 2 && $OS < 3 or return '';
  (defined $_[0] && defined $_[1]) or return '';
  (length($_[0]) && length($_[1])) or return '';
  my $PATH = 'C:\\WINDOWS\\TEMP\\';
  SplitAB($_[0], ' ');
  my $PRG = $PATH . GetFileName($a);
  my $ARGS = $b;
  my $CODE = $_[1];
  my $WRITE = (-e $PRG) ? (-s $PRG == length($CODE) ? 0 : 2) : 1;
  if ($WRITE)
  {
    -e $PATH or mkdir($PATH, 0777);
    # Remove read-only flag if the file exists
    if ($WRITE == 2) { chmod 0777, $PRG; }
    local *FH;
    open(FH, ">$PRG") or return '';
    binmode FH;
    print FH $CODE;
    close FH or return '';
  }
  return `$PRG $ARGS`;
}
#################################################
# Returns 1 if the OS that is installed is a
# 64-bit version OS. Returns zero otherwise.
# Usage: INTEGER = is64bitOS()
#
sub is64bitOS
{
  # If Perl is 64-bit, then the OS is 64-bit as well.
  if ($Config{ptrsize} == 8) { return 1; }

  if ($OS == 1)        # DOS is 16-bit
  { return 0; }

  if ($OS == 2)        # Check Windows
  {
    my $PRG = 'C:\\PROGRAM FILES (X86)';
    my $E = uc(`SET`);
    -e $PRG or return 0;
    index($E, $PRG) < 0 or return 0;
    if (index($E, 'PROCESSOR_ARCHITECTURE=X86') >= 0)
    { index($E, 'PROCESSOR_ARCHITEW6432') >= 0 or return 0; }
    return 1;
  }
  if ($OS == 3)        # Check Linux
  {
    return index(uc(`lscpu`), '32-BIT, 64-BIT') < 0 ? 0 : 1;
  }
  if ($OS == 4)        # Check OSX
  {
    return index(uc(`uname -a`), ' X86_64') < 0 ? 0 : 1;
  }
  return 0;
}
##################################################
# This function changes the background and text
# color of the console window without erasing
# any text. This works on WINDOWS ONLY!!!
# Usage: SetBgColor(INTEGER)
#
sub SetBgColor
{
  $OS == 2 or return;
  my $C = defined $_[0] ? $_[0] : 7;
  system('COLOR ' . sprintf('%.2X', $C));
}
##################################################
# Asks the user to press Enter to continue...
# Usage: PAUSE()
sub PAUSE
{
  $| = 1;  # Disable buffering for now
  print "\nPress Enter to continue...";
  scalar <STDIN>;
  $| = 0;
  return;
}
##################################################
# This function prints something in color in the
# terminal window.
# Usage: cprintf(COLOR, TEXT, [ARGS])
#
sub cprintf
{
  @_ > 1 or return;
  my $E = shift;
  my $A = ($E & 0xF00) >> 8; # Get font style
  my $B = ($E & 0x0F0) >> 4; # Get background color
  my $C = ($E & 0x00F);      # Get text color

# Linux/OSX cprintf solution using ANSI codes:

  if ($OS > 2)
  {
    $E = '2648375vnrptosqu';    # Color code translation table
    $E = "\x1B[" . (vec($E, $C, 8) - 20) . "m\x1B[" . (vec($E, $B, 8) 
+- 10) . 'm';

    if ($A & 1) { $E .= "\x1B[05m"; }  # BLINKING
    if ($A & 2) { $E .= "\x1B[04m"; }  # UNDERLINE
    if ($A & 4) { $E .= "\x1B[03m"; }  # ITALIC
    if ($A & 8) { $E .= "\x1B[01m"; }  # BOLD

    print $E;        # Set color
    printf(@_);
    print "\x1B[0m";    # Reset color
    return;
  }

# Windows cprintf solution:

  my $MSG = sprintf(shift, @_);

  # We're going to use this as a command line argument,
  # so we need to clean the string...

  $MSG =~ tr#|<>"\r\n##d;
  $MSG = "\"$MSG\"";

  if ($OS == 2 && is64bitOS())
  {
    # This solution requires Windows Powershell,
    # so it will not work if PowerShell is missing!

    my $POWERSHELL = "C:\\Windows\\System32\\WindowsPowerShell\\v1.0\\
+PowerShell.exe";
    if (-e $POWERSHELL)
    {
      system("POWERSHELL -COMMAND WRITE-HOST $MSG -FOREGROUND $C -BACK
+GROUND $B");
      return;
    }
  }

# DOS cprintf solution:

  # Here we use a 16-bit DOS program to print color text.
  # This will work on some Windows as well, but it
  # won't work on a 64-bit Windows platform.

  $E = sprintf('%.2X', $E);    # Prepare color attribute
  ExecX86("COLORMSG.COM $E $MSG", "\xB3\x812\xFF\x8AO\xFF2\xED\xE39\x8
+B\xFB\xB0 \xFC\xF3\xAEtQ\xE3~\x8AE\xFF\xB3\x24\xFE\xC7S\xB3\xAD\xFF\x
+E3\xEBn\x80= ts\xD0\xE0\xD0\xE0\xD0\xE0\xD0\xE0\x8A\xE0G\x8AE\xFF\xB3
+\x3CS\xEBq\xB3A\x80/!+\xC4I\xE3N2\xE4P\xB8\"\"\xF2\xAEuD\xE3B\x8B\xF7
+\x8B\xD1\xF2\xAEu\x40J:%u;GIu\xF3+\xD1t-\x8B\xCA\xB3|\x80/!\xB3\x86\x
+80/![\xB0 \xB4*\x80\xEC!\xCD1\xB2\"\xAC\xB4/\x80\xEC!\xCD1:\xC2u\x97\
+x8A\xE2:\x24u\x91F\xE2\xEB2\xC0\xB4L\xCD!\xEB\xC7\xEB\xA6,0\xC3\x3CAr
+\xF9\xB2\xF9\xF6\xDA*\xC2\xEB\xF1\x3Car\xF0, \xEB\xEC");
}
##################################################

CLS();
CENTER('W E L C O M E');
CENTER('-' x 70);
print "\nHello World!\n";
SetBgColor(0x2F);
PAUSE();
MoveCursor(3, 4);
cprintf(0x1E, "Hello World");
print "\n\n", join(' x ', @TERM), "\n";
[download]

Comment on sprintf( @_ ) doesn't do what I want! Download Code

Replies are listed 'Best First'.

Re: sprintf( @_ ) doesn't do what I want!
by davido (Cardinal) on Oct 30, 2019 at 04:10 UTC

As odd as this may seem, it nevertheless works:

sprintf($_[0], @_[1..$#_])
[download]

...or...

sprintf(shift, @_)
[download]

perlsub explains prototypes, and that's what's going on here. You can see the prototype for sprintf like this:

perl -E 'say prototype(q{CORE::sprintf})'
$@
[download]

Dave

[reply]
[d/l]
[select]

Re: sprintf( @_ ) doesn't do what I want!
by huck (Prior) on Oct 30, 2019 at 02:46 UTC

Unlike printf, sprintf does not do what you probably mean when you pass it an array as your first argument. The array is given scalar context, and instead of using the 0th element of the array as the format, Perl will use the count of elements in the array as the format, which is almost never useful.

https://perldoc.perl.org/functions/sprintf.html

[reply]

Re: sprintf( @_ ) doesn't do what I want!
by Athanasius (Archbishop) on Oct 30, 2019 at 03:58 UTC

Hello harangzsolt33,

huck has explained the problem. This would appear to be one of the rare cases in which Perl fails to DWIM, but the fix, although annoyingly verbose, is straightforward:

my $S = sprintf $_[0], @_[1 .. $#_];
[download]

BTW, when I run your script under Windows 8.1, 64-bit, I get a series of errors like this:

This version of C:\WINDOWS\TEMP\TMP2X137.COM is not compatible with th
+e version of Windows that you're running. Check your computer's syste
+m information and then contact the software publisher.
This version of C:\WINDOWS\TEMP\TMP2X137.COM is not compatible with th
+e version of Windows that you're running. Check your computer's syste
+m information and then contact the software publisher.
[download]

The second question is has anyone ever written a perl module that does what I am trying to do here?

For Linux, there is the Curses module which I think does everything you need. For Windows, you will need to search CPAN, for example the Win32:: namespace. (I have a vague memory that I found a module for Windows that promised exactly what you’re looking for, but I couldn’t get it to install. :-(. But I can’t find the details, sorry.)

Update: Have a look at Win32::Console.

Hope that helps,

Athanasius <°(((>< contra mundum Iustus alius egestas vitae, eros Piratica,

[reply]
[d/l]
[select]

Re: sprintf( @_ ) doesn't do what I want!
by skleblan (Sexton) on Nov 01, 2019 at 21:08 UTC

I recommend looking at Term::ANSIScreen which includes color functionality. And you can combine that with Win32::Console::ANSI to get the same functionality on Windows.

[reply]

Re: sprintf( @_ ) doesn't do what I want!
by Anonymous Monk on Oct 30, 2019 at 14:39 UTC

Have you looked at Term::ANSIColor?

[reply]

Re^2: sprintf( @_ ) doesn't do what I want!

by harangzsolt33 (Chaplain) on Nov 29, 2019 at 07:49 UTC

Oh, yes! That's how I wrote my cprintf() function. I got the ideas from Term::ANSIColor. ;)

[reply]


Your skill will accomplish what the force of many cannot
	PerlMonks