#  (gH)   --  strFuncs.pm  ;  TimeStamp (unix) : 23 Novembre 00 14:01
#                                                                            #
##############################################################################
#                                                                            #
#                                                                            #
#  Fichier : strFuncs.pm v-1.02                                              #
#                                                                            #
#                                                                            #
#                                 Gilles.HUNAULT@univ-angers.fr              #
#                                 http://www.info.univ-angers.fr/~gh/gh.html #
#                                                                            #
#                                                                            #
# " Sous-programmes perl de fonctions utiles sur chaine de caractères "      #
#                                                                            #
#                                                                            #
##############################################################################
#                                                                            #
# 1. peut s'utiliser par                                                     #
#                                                                            #
#         use strFuncs ;                                                     #
#                                                                            #
#    si le module est dans le répertoire courant                             #
#                                                                            #
##############################################################################
#                                                                            #
# 2. peut s'utiliser par                                                     #
#                                                                            #
#         use lib "/usr/local/bin/scriptsPerl/" ;                            #
#         use strFuncs ;                                                     #
#                                                                            #
#    si le module est dans le répertoire /usr/local/bin/scriptsPerl/         #
#                                                                            #
##############################################################################
#                                                                            #
# 3. peut s'utiliser par                                                     #
#                                                                            #
#         use lib $ENV{"PERL_MACROS"} ;                                      #
#         use strFuncs ;                                                     #
#                                                                            #
#    si le module est dans le répertoire indiqué par la variable             #
#    d'environnement PERL_MACROS, par exemple :                              #
#                                                                            #
#         export PERL_MACROS=/usr/local/bin/scriptsPerl/                     #
#                (pour bash, sous Linux)                                     #
#         set PERL_MACROS=c:\Scripts\Perl\                                   #
#                (sous Dos/Windows)                                          #
#                                                                            #
#                                                                            #
##############################################################################

 package  strFuncs ;
 require  Exporter ;
 @ISA     = qw(Exporter) ;

 @EXPORT  = (<<"FIN_DE_LA_LISTE_DES_FONCTIONS" =~ m/^\s*(.+)/xgm) ;
    premierMot
    phraseSansDernierMot
    phraseSansPremierMot
    premierEtReste
    debutEtDernier
    sprintG
    verifAdr
    nsuivant
    nettoieId
    initialeMajuscule
    nbMots
    attends
    sansEspaceAuDebut
    sansEspaceEnFin
    sansEspaceDebutEtFin
    nomFichierSansExtension
    dernierePosition
    chaineVide
    maju
    sansCmt
    cpy
FIN_DE_LA_LISTE_DES_FONCTIONS

# la fonction initialeMajuscule n'est pas une erreur
# (à cause de ucfirst, /i et \u en perl) mais une
# volonté de "nettoyer" la chaine

#############################################################
##                                                          #
##   C. Sous-programmes sur chaines de caractères           #
##                                                          #
#############################################################

sub premierMot {
    my $phr = $_[0] ;
    my @mt  = split(" ",$phr) ;
    my $mu  = $mt[0] ;
    if ($ghDbg) { print STDERR " mot  1  : -- $mu  -- \n"; } ;
    return $mu ;
} ; # sub premierMot {

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

sub dernierMot {
    my $phr = $_[0] ;
    my @mt  = split(" ",$phr) ;
    my $mu  = $mt[$#mt] ;
    if ($ghDbg) { print STDERR " mot  x  : -- $mu  -- \n"; } ;
    return $mu ;
} ; # sub dernierMot {

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

sub phraseSansDernierMot {
    my $phr = $_[0] ;
    my @mt  = split(" ",$phr) ;
    $mt[$#mt] = "" ;
    my $mu  = join(" ",@mt) ;
    if ($ghDbg) { print STDERR " sans x  : -- $mu  -- \n"; } ;
    return $mu ;
} ; # sub phraseSansDernierMot

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

sub phraseSansPremierMot {
    my $phr = $_[0] ;
    my @mt  = split(" ",$phr) ;
    $mt[0] = "" ;
    my $mu  = join(" ",@mt) ;
    if ($ghDbg) { print STDERR " sans 1  : -- $mu  -- \n"; } ;
    return $mu ;
} ; # sub phraseSansPremierMot

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

sub premierEtReste {
    my $phr = $_[0] ;
    my @mt  = split(" ",$phr) ;
    my $pm  = $mt[0] ;
    $mt[0] = "" ;
    my $re  = join(" ",@mt) ;
    return ($pm,$re) ;
} ; # sub premierEtReste

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

sub debutEtDernier {
    my $phr = $_[0] ;
    #$phr =~ s/^ //g ;
    while (substr($phr,0,1) eq " ") { $phr = substr($phr,1) ; } ;
##if ($ghDbg) { print STDERR " phr =*$phr*\n" ;  } ;
    if ($phr eq "") { $phr="### ###" ; } ;
    my @mt  = split(" ",$phr) ;
    my $dm  = $mt[$#mt] ;
    $mt[$#mt] = "" ;
    my $re  = join(" ",@mt) ;
    return ($re,$dm) ;
} ; # fin de sub debutEtDernier

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

sub sprintG { # comme sprintf mais ne déborde pas
# par exemple sprintG(25,$pom) équivaut à sprintf("%-25s",$pom)
    my $len = $_[0] ;
    my $phr = $_[1] ;
    my $fmt = "%-".$len."s" ;
    my $lph = sprintf($fmt,$phr).(" "x50)  ;
    return substr($lph,0,$len) ;
} ; # fin sub sprintG

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

sub verifieAdrWeb {
  my $ancAdr =   $_[0] ;
  $ancAdr    =~ s/ //g ;
  my $retAdr  = "???" ;
  if (length($ancAdr)==0) { $retAdr = "???" ; } else { $retAdr = $ancAdr ; } ;
  return $retAdr ;
} ; # fin de sub verifAdr

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

sub verifiePseudoEbay {
  my $ancPse =   $_[0] ;
  $ancPse    =~ s/ //g ;
  my $retPse  = "???" ;
  if (length($ancPse)==0) { $retPse = "???" ; } else { $retPse = $ancPse ; } ;
  return $retPse ;
} ; # fin de sub verifAdr

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

sub verifieCoteEbay {
  my $ancCote =   $_[0] ;
  if (length($ancCote)==0) { $retCote = -9999 ; } else { $retCote = $ancCote ; } ;
  return $retCote ;
} ; # fin de sub verifAdr

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

sub nsuivant {

  $dbgSuiv = 0 ; # 0 normal, 1 pour debug simple 2 pour debug lourd

  $oldNom = $_[0] ;
  $vxl    = length($oldNom) ;
  if ($dbgSuiv>0) { if ($ghDbg) { print STDERR " on veut le nom suivant de $oldNom longueur $vxl\n" ; } ;  } ;

  $oldNom  =~ tr /A-Z/a-z/ ;
  $debNom  = substr($oldNom,0,$vxl-1) ;
  $lastCar = substr($oldNom,$vxl-1,1) ;

  if (ord($lastCar) < ord("z")) {

       $newNom = $debNom.chr(1+ord($lastCar)) ;
    if ($dbgSuiv>1) {
      $olc = ord($lastCar) ;
      $cdz = ord("z") ;
      if ($ghDbg) { print STDERR " ord de last car vaut $olc et celui de z est $cdz " ;  } ;
      if ($ghDbg) { print STDERR " avant le while : debnom $debNom \n" ;  } ;
    } ; # fin de si
  } else {

    $debNom = $oldNom  ;
    $lastCar = substr($oldNom,$vxl-1,1);

    if ($dbgSuiv>1) { if ($ghDbg) { print STDERR " avant le while : debnom $debNom \n" ; } ;  } ;

    $nbw = 0 ;
    while (($lastCar eq "z") and (length($debNom)>0)) {
          $nbw++ ;
          $debNom  = substr($debNom,0,length($debNom)-1) ;
          if (length($debNom)>0) {
             $lastCar = substr($debNom,length($debNom)-1,1) ;
          } else {
             $lastCar = "" ;
          } ; # fin de si
          $debNom =~ s/ //g ;
          if ($dbgSuiv>1) { if ($ghDbg) { print STDERR "   $nbw  dans  le while : debnom *$debNom* lc $lastCar \n" ; } ;  } ;
    } ; # end /* fin tant que */
    if ($dbgSuiv>1) { if ($ghDbg) { print STDERR " apres le while : debnom $debNom lastcar $lastCar on a $nbw fois z \n" ; } ;  } ;

    if (length($debNom)>0) {
       $debNom  = substr($debNom,0,length($debNom)-1) ;
       $newNom  = $debNom.chr(1+ord($lastCar))        ;
    } else {
          $vxl  = $vxl + 1 ;
          $newNom = ""      ;
    } ; # fin de si

    if ($nbw==$vxl) { $vxl = $vxl + 1 } ;

    while (length($newNom) < $vxl) {
       $newNom .= "a" ;
    } ; # fin de tant que

  } ; # fin du si sur le tout premier lastCar

  $newNom =~ tr/A-Z/a-z/ ;
  if ($dbgSuiv>0) {
     if ($ghDbg) { print STDERR " ce doit etre $newNom\n" ;  } ;
     &attends() ;
  } ; # fin de si

  return $newNom ;

} ; # fin sub nsuivant

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

sub nettoieId {
  $entree  =  $_[0]  ;   $modeNom = $_[1] ; # 1 pour nom, 0 pour prenom, 2 pour ignorer chasse
  $sortie  =  $entree ;
  $sortie  =~ s/^ //g ;  # supression des blancs de tete
  $sortie  =~ s/ $//g ;  # supression des blancs de queue
  $sortie  =~ s/\(//g ;  # supression de parenthèse ouvrante
  $sortie  =~ s/\)//g ;  # supression de parenthèse fermante
  $sortie  =~ s/>//g ;   # supression de >
  $sortie  =~ s/<//g ;   # supression de <
  $sortie  =~ s/"//g ;   # supression de guillemet
  $sortie  =~ s/'//g ;   # supression d'apostrophe
  $sortie  =~ s/\\//g ;   # supression d'anti-slash
  $sortie  =~ s/&//g ;   # supression du &
  $sortie  =~ s/^ //g ;  # supression des blancs de tete
  $sortie  =~ s/ $//g ;  # supression des blancs de queue
  # certains utilisent =iso
  if ($modeNom==1) { $sortie =~ tr/a-z/A-Z/ ; } ; # passage en majuscules
  if (substr($sortie,0,5) eq "=?ISO") { $sortie = "" } ;
  if (substr($sortie,0,5) eq "=?iso") { $sortie = "" } ;
  return $sortie ;
} ; # fin sub nettoieId

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

sub initialeMajuscule {

  $entree  =  $_[0]  ;
  $sortie  =  $entree ;
  $sortie  =~ s/^ //g ;              # supression des blancs de tete
  $sortie  =~ s/ $//g ;              # supression des blancs de queue
  $sortie  =~ tr/A-Z/a-z/ ;          # passage en minuscules
  $premc   =  substr($sortie,0,1)  ; # premier caractère
  $premc   =~ tr/a-z/A-Z/ ;          # passage en majuscules
  $sortie  =  "$premc".substr($sortie,1,length($sortie)-1) ;

} ; # fin de sub initialeMajuscule

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

sub nbMots {

my $nbesp ;
my $entre   =  $_[0]  ;
   $entree  =  $_[0]  ;
   $entree  =~ s/,/ /g ;               # remplaces les virgules par des blancs
   $entree  =~ s/^ //g ;               # supression des blancs de tete
   $entree  =~ s/ $//g ;               # supression des blancs de queue
   while ($entree  =~ s/  / /g) { } ;
   if (length($entree)==0) { $nbesp = 0 ; } else {
      $nbesp  = 1 + ($entree =~ s/ /*/g) ;
   } ; # fin de si
   return $nbesp ;

} ; # fin de sub nbMots

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

sub sansEspaceAuDebut {

my $entre   =  $_[0]  ;
   while ($entre   =~ s/^ //g) { }  ;
   return $entre ;

} ; # fin de sub sansEspaceAuDebut

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

sub sansEspaceEnFin {

my $entre   =  $_[0]  ;
   while ($entre   =~ s/ $//g) { }  ;
   return $entre ;

} ; # fin de sub sansEspaceEnFin

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

sub sansEspaceDebutEtFin {

my $entre   =  $_[0]  ;
   $entre   =  &sansEspaceAuDebut($entre) ;
   $entre   =  &sansEspaceEnFin($entre) ;
   return $entre ;

} ; # fin sub sansEspaceDebutEtFin

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

sub dernierePosition {

my $aig   = $_[0] ; # aiguille
my $phraz = $_[1] ; # botte de foin
my $pdr   = index(reverse($phraz),$aig) ;
my $dp    = -2 ;
   if ($pdr == -1) { $dp = -1  } else { $dp = length($phraz)-$pdr-1 ; } ;
   return $dp ;

} ; # fin sub dernierePosition

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

sub chaineVide { # renvoie 1 si la chaine est vide, 0 sinon

  if (length(&sansEspaceDebutEtFin($_[0]))>0)  { return 0 ; } else { return 1 ; } ;

} ; # fin sub chaineVide

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

sub nomFichierSansExtension {

my $nomF    =  $_[0]  ;
my $dpdp    =  &dernierePosition(".",$nomF) ;
my $nNom    =  substr($nomF,0,$dpdp) ;
   return $nNom ;

} ; # sub nomFichierSansExtension

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

sub  sansCmt  {

  $sansCmt_dbg = 0 ; # mettre 1 pour affichage de debug, 0 en mode normal

  $ligneAvant = $_[0] ;
  $ligneApres = $ligneAvant ;
  if ($sansCmt_dbg>0) { print " avant : $ligneAvant \n" ; }
  $posDiese = index($ligneAvant,"#") ;
  if ($sansCmt_dbg>0) {   print " diese vu en $posDiese \n" ; }
  if ($posDiese>-1) { $ligneApres = substr($ligneAvant,0,$posDiese) ; } ;
  if ($sansCmt_dbg>0) {   print " apres = $ligneApres\n" ; }

  return $ligneApres ;

} ; # fin sub sansCmt

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

sub  maju  { # mode français : gère les accents (sans passer par les LOCALE)

  $ligneAvant =  $_[0] ;
  $ligneApres =  uc($ligneAvant) ;
  $ligneApres =~ s/à/A/g ;
  $ligneApres =~ s/â/A/g ;
  $ligneApres =~ s/ç/C/g ;
  $ligneApres =~ s/é/E/g ;
  $ligneApres =~ s/è/E/g ;
  $ligneApres =~ s/ê/E/g ;
  $ligneApres =~ s/î/I/g ;
  $ligneApres =~ s/ô/O/g ;
  $ligneApres =~ s/û/U/g ;

  return $ligneApres ;

} ; # fin sub maju

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

sub  cpy  {

 print "\n" ;
 print " Copyright  2000  - email : gilles.hunault\@univ-angers.fr \n" ;
 print "                    http://www.info.univ-angers.fr/~gh/gh.html \n" ;
 print "\n" ;

} ; # fin sub cpy

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

sub attends {

    print STDERR " ok ? " ;
    chop (my $repgh = <STDIN>);
    if (length($repgh)>0) { exit -1 } ;
    return ;

} ; # fin sub attends

# cette dernière ligne est obligatoire pour dire que le chargement est ok :

1 ;

##################################### fin du fichier strFuncs.pm ##########